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);
88 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
91 #include "diagnostic.h"
93 #include "langhooks.h"
94 #include "langhooks-def.h"
96 /* VMS-specific definitions */
99 #define O_RDONLY 0 /* Open arg for Read/Only */
100 #define O_WRONLY 1 /* Open arg for Write/Only */
101 #define read(fd,buf,size) VMS_read (fd,buf,size)
102 #define write(fd,buf,size) VMS_write (fd,buf,size)
103 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
104 #define fopen(fname,mode) VMS_fopen (fname,mode)
105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
107 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
108 static int VMS_fstat (), VMS_stat ();
109 static char * VMS_strncat ();
110 static int VMS_read ();
111 static int VMS_write ();
112 static int VMS_open ();
113 static FILE * VMS_fopen ();
114 static FILE * VMS_freopen ();
115 static void hack_vms_include_specification ();
116 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
117 #define ino_t vms_ino_t
118 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
138 /* Externals defined here. */
140 /* Stream for reading from the input file. */
143 /* These definitions parallel those in c-decl.c so that code from that
144 module can be used pretty much as is. Much of these defs aren't
145 otherwise used, i.e. by g77 code per se, except some of them are used
146 to build some of them that are. The ones that are global (i.e. not
147 "static") are those that ste.c and such might use (directly
148 or by using com macros that reference them in their definitions). */
150 tree string_type_node
;
152 /* The rest of these are inventions for g77, though there might be
153 similar things in the C front end. As they are found, these
154 inventions should be renamed to be canonical. Note that only
155 the ones currently required to be global are so. */
157 static tree ffecom_tree_fun_type_void
;
159 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
160 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
161 tree ffecom_integer_one_node
; /* " */
162 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
164 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
165 just use build_function_type and build_pointer_type on the
166 appropriate _tree_type array element. */
168 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
169 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
170 static tree ffecom_tree_subr_type
;
171 static tree ffecom_tree_ptr_to_subr_type
;
172 static tree ffecom_tree_blockdata_type
;
174 static tree ffecom_tree_xargc_
;
176 ffecomSymbol ffecom_symbol_null_
185 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
186 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
188 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
189 tree ffecom_f2c_integer_type_node
;
190 tree ffecom_f2c_ptr_to_integer_type_node
;
191 tree ffecom_f2c_address_type_node
;
192 tree ffecom_f2c_real_type_node
;
193 tree ffecom_f2c_ptr_to_real_type_node
;
194 tree ffecom_f2c_doublereal_type_node
;
195 tree ffecom_f2c_complex_type_node
;
196 tree ffecom_f2c_doublecomplex_type_node
;
197 tree ffecom_f2c_longint_type_node
;
198 tree ffecom_f2c_logical_type_node
;
199 tree ffecom_f2c_flag_type_node
;
200 tree ffecom_f2c_ftnlen_type_node
;
201 tree ffecom_f2c_ftnlen_zero_node
;
202 tree ffecom_f2c_ftnlen_one_node
;
203 tree ffecom_f2c_ftnlen_two_node
;
204 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
205 tree ffecom_f2c_ftnint_type_node
;
206 tree ffecom_f2c_ptr_to_ftnint_type_node
;
208 /* Simple definitions and enumerations. */
210 #ifndef FFECOM_sizeMAXSTACKITEM
211 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
212 larger than this # bytes
213 off stack if possible. */
216 /* For systems that have large enough stacks, they should define
217 this to 0, and here, for ease of use later on, we just undefine
220 #if FFECOM_sizeMAXSTACKITEM == 0
221 #undef FFECOM_sizeMAXSTACKITEM
227 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
228 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
229 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
230 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
231 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
232 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
233 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
234 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
235 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
236 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
237 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
238 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
239 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
240 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
244 /* Internal typedefs. */
246 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
248 /* Private include files. */
251 /* Internal structure definitions. */
253 struct _ffecom_concat_list_
258 ffetargetCharacterSize minlen
;
259 ffetargetCharacterSize maxlen
;
262 /* Static functions (internal). */
264 static void ffecom_init_decl_processing
PARAMS ((void));
265 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
266 static tree
ffecom_widest_expr_type_ (ffebld list
);
267 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
268 tree dest_size
, tree source_tree
,
269 ffebld source
, bool scalar_arg
);
270 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
271 tree args
, tree callee_commons
,
273 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
274 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
275 bool is_f2c_complex
, tree type
,
276 tree args
, tree dest_tree
,
277 ffebld dest
, bool *dest_used
,
278 tree callee_commons
, bool scalar_args
, tree hook
);
279 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
280 bool is_f2c_complex
, tree type
,
281 ffebld left
, ffebld right
,
282 tree dest_tree
, ffebld dest
,
283 bool *dest_used
, tree callee_commons
,
284 bool scalar_args
, bool ref
, tree hook
);
285 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
286 ffebld expr
, bool with_null
);
287 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
288 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
289 static ffecomConcatList_
290 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
292 ffetargetCharacterSize max
);
293 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
294 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
295 ffetargetCharacterSize max
);
296 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
297 ffesymbol member
, tree member_type
,
298 ffetargetOffset offset
);
299 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
300 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
301 bool *dest_used
, bool assignp
, bool widenp
);
302 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
303 ffebld dest
, bool *dest_used
);
304 static tree
ffecom_expr_power_integer_ (ffebld expr
);
305 static void ffecom_expr_transform_ (ffebld expr
);
306 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
307 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
309 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
310 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
311 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
312 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
313 static tree
ffecom_get_identifier_ (const char *text
);
314 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
317 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
318 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
319 static tree
ffecom_init_zero_ (tree decl
);
320 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
322 static tree
ffecom_intrinsic_len_ (ffebld expr
);
323 static void ffecom_let_char_ (tree dest_tree
,
325 ffetargetCharacterSize dest_size
,
327 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
328 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
329 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
330 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
332 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
334 static void ffecom_start_progunit_ (void);
335 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
336 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
337 static void ffecom_transform_common_ (ffesymbol s
);
338 static void ffecom_transform_equiv_ (ffestorag st
);
339 static tree
ffecom_transform_namelist_ (ffesymbol s
);
340 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
342 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
343 tree
*size
, tree tree
);
344 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
345 tree dest_tree
, ffebld dest
,
346 bool *dest_used
, tree hook
);
347 static tree
ffecom_type_localvar_ (ffesymbol s
,
350 static tree
ffecom_type_namelist_ (void);
351 static tree
ffecom_type_vardesc_ (void);
352 static tree
ffecom_vardesc_ (ffebld expr
);
353 static tree
ffecom_vardesc_array_ (ffesymbol s
);
354 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
355 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
356 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
358 /* These are static functions that parallel those found in the C front
359 end and thus have the same names. */
361 static tree
bison_rule_compstmt_ (void);
362 static void bison_rule_pushlevel_ (void);
363 static void delete_block (tree block
);
364 static int duplicate_decls (tree newdecl
, tree olddecl
);
365 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
366 static void finish_function (int nested
);
367 static const char *ffe_printable_name (tree decl
, int v
);
368 static tree
lookup_name_current_level (tree name
);
369 static struct binding_level
*make_binding_level (void);
370 static void pop_f_function_context (void);
371 static void push_f_function_context (void);
372 static void push_parm_decl (tree parm
);
373 static tree
pushdecl_top_level (tree decl
);
374 static int kept_level_p (void);
375 static tree
storedecls (tree decls
);
376 static void store_parm_decls (int is_main_program
);
377 static tree
start_decl (tree decl
, bool is_top_level
);
378 static void start_function (tree name
, tree type
, int nested
, int public);
379 static void ffecom_file_ (const char *name
);
380 static void ffecom_close_include_ (FILE *f
);
381 static int ffecom_decode_include_option_ (char *spec
);
382 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
385 /* Static objects accessed by functions in this module. */
387 static ffesymbol ffecom_primary_entry_
= NULL
;
388 static ffesymbol ffecom_nested_entry_
= NULL
;
389 static ffeinfoKind ffecom_primary_entry_kind_
;
390 static bool ffecom_primary_entry_is_proc_
;
391 static tree ffecom_outer_function_decl_
;
392 static tree ffecom_previous_function_decl_
;
393 static tree ffecom_which_entrypoint_decl_
;
394 static tree ffecom_float_zero_
= NULL_TREE
;
395 static tree ffecom_float_half_
= NULL_TREE
;
396 static tree ffecom_double_zero_
= NULL_TREE
;
397 static tree ffecom_double_half_
= NULL_TREE
;
398 static tree ffecom_func_result_
;/* For functions. */
399 static tree ffecom_func_length_
;/* For CHARACTER fns. */
400 static ffebld ffecom_list_blockdata_
;
401 static ffebld ffecom_list_common_
;
402 static ffebld ffecom_master_arglist_
;
403 static ffeinfoBasictype ffecom_master_bt_
;
404 static ffeinfoKindtype ffecom_master_kt_
;
405 static ffetargetCharacterSize ffecom_master_size_
;
406 static int ffecom_num_fns_
= 0;
407 static int ffecom_num_entrypoints_
= 0;
408 static bool ffecom_is_altreturning_
= FALSE
;
409 static tree ffecom_multi_type_node_
;
410 static tree ffecom_multi_retval_
;
412 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
413 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
414 static bool ffecom_doing_entry_
= FALSE
;
415 static bool ffecom_transform_only_dummies_
= FALSE
;
416 static int ffecom_typesize_pointer_
;
417 static int ffecom_typesize_integer1_
;
419 /* Holds pointer-to-function expressions. */
421 static tree ffecom_gfrt_
[FFECOM_gfrt
]
424 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
425 #include "com-rt.def"
429 /* Holds the external names of the functions. */
431 static const char *const ffecom_gfrt_name_
[FFECOM_gfrt
]
434 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
435 #include "com-rt.def"
439 /* Whether the function returns. */
441 static const bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
445 #include "com-rt.def"
449 /* Whether the function returns type complex. */
451 static const bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
455 #include "com-rt.def"
459 /* Whether the function is const
460 (i.e., has no side effects and only depends on its arguments). */
462 static const bool ffecom_gfrt_const_
[FFECOM_gfrt
]
465 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
466 #include "com-rt.def"
470 /* Type code for the function return value. */
472 static const ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
475 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
476 #include "com-rt.def"
480 /* String of codes for the function's arguments. */
482 static const char *const ffecom_gfrt_argstring_
[FFECOM_gfrt
]
485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
486 #include "com-rt.def"
490 /* Internal macros. */
492 /* We let tm.h override the types used here, to handle trivial differences
493 such as the choice of unsigned int or long unsigned int for size_t.
494 When machines start needing nontrivial differences in the size type,
495 it would be best to do something here to figure out automatically
496 from other information what type to use. */
499 #define SIZE_TYPE "long unsigned int"
502 #define ffecom_concat_list_count_(catlist) ((catlist).count)
503 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
504 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
505 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
507 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
508 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
510 /* For each binding contour we allocate a binding_level structure
511 * which records the names defined in that contour.
514 * 1) one for each function definition,
515 * where internal declarations of the parameters appear.
517 * The current meaning of a name can be found by searching the levels from
518 * the current one out to the global one.
521 /* Note that the information in the `names' component of the global contour
522 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
526 /* A chain of _DECL nodes for all variables, constants, functions,
527 and typedef types. These are in the reverse of the order supplied.
531 /* For each level (except not the global one),
532 a chain of BLOCK nodes for all the levels
533 that were entered and exited one level down. */
536 /* The BLOCK node for this level, if one has been preallocated.
537 If 0, the BLOCK is allocated (if needed) when the level is popped. */
540 /* The binding level which this one is contained in (inherits from). */
541 struct binding_level
*level_chain
;
543 /* 0: no ffecom_prepare_* functions called at this level yet;
544 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
545 2: ffecom_prepare_end called. */
549 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
551 /* The binding level currently in effect. */
553 static struct binding_level
*current_binding_level
;
555 /* A chain of binding_level structures awaiting reuse. */
557 static struct binding_level
*free_binding_level
;
559 /* The outermost binding level, for names of file scope.
560 This is created when the compiler is started and exists
561 through the entire run. */
563 static struct binding_level
*global_binding_level
;
565 /* Binding level structures are initialized by copying this one. */
567 static const struct binding_level clear_binding_level
569 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
571 /* Language-dependent contents of an identifier. */
573 struct lang_identifier
575 struct tree_identifier ignore
;
576 tree global_value
, local_value
, label_value
;
580 /* Macros for access to language-specific slots in an identifier. */
581 /* Each of these slots contains a DECL node or null. */
583 /* This represents the value which the identifier has in the
584 file-scope namespace. */
585 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
586 (((struct lang_identifier *)(NODE))->global_value)
587 /* This represents the value which the identifier has in the current
589 #define IDENTIFIER_LOCAL_VALUE(NODE) \
590 (((struct lang_identifier *)(NODE))->local_value)
591 /* This represents the value which the identifier has as a label in
592 the current label scope. */
593 #define IDENTIFIER_LABEL_VALUE(NODE) \
594 (((struct lang_identifier *)(NODE))->label_value)
595 /* This is nonzero if the identifier was "made up" by g77 code. */
596 #define IDENTIFIER_INVENTED(NODE) \
597 (((struct lang_identifier *)(NODE))->invented)
599 /* In identifiers, C uses the following fields in a special way:
600 TREE_PUBLIC to record that there was a previous local extern decl.
601 TREE_USED to record that such a decl was used.
602 TREE_ADDRESSABLE to record that the address of such a decl was used. */
604 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
605 that have names. Here so we can clear out their names' definitions
606 at the end of the function. */
608 static tree named_labels
;
610 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
612 static tree shadowed_labels
;
614 /* Return the subscript expression, modified to do range-checking.
616 `array' is the array to be checked against.
617 `element' is the subscript expression to check.
618 `dim' is the dimension number (starting at 0).
619 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
623 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
624 const char *array_name
)
626 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
627 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
632 if (element
== error_mark_node
)
635 if (TREE_TYPE (low
) != TREE_TYPE (element
))
637 if (TYPE_PRECISION (TREE_TYPE (low
))
638 > TYPE_PRECISION (TREE_TYPE (element
)))
639 element
= convert (TREE_TYPE (low
), element
);
642 low
= convert (TREE_TYPE (element
), low
);
644 high
= convert (TREE_TYPE (element
), high
);
648 element
= ffecom_save_tree (element
);
651 /* Special handling for substring range checks. Fortran allows the
652 end subscript < begin subscript, which means that expressions like
653 string(1:0) are valid (and yield a null string). In view of this,
654 enforce two simpler conditions:
655 1) element<=high for end-substring;
656 2) element>=low for start-substring.
657 Run-time character movement will enforce remaining conditions.
659 More complicated checks would be better, but present structure only
660 provides one index element at a time, so it is not possible to
661 enforce a check of both i and j in string(i:j). If it were, the
662 complete set of rules would read,
663 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
664 ((low<=i<=high) && (low<=j<=high)) )
670 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, element
, high
);
672 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, low
, element
);
676 /* Array reference substring range checking. */
678 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
683 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
685 ffecom_2 (LE_EXPR
, integer_type_node
,
703 var
= concat (array_name
, "[", (dim
? "end" : "start"),
704 "-substring]", NULL
);
705 len
= strlen (var
) + 1;
706 arg1
= build_string (len
, var
);
711 len
= strlen (array_name
) + 1;
712 arg1
= build_string (len
, array_name
);
716 var
= xmalloc (strlen (array_name
) + 40);
717 sprintf (var
, "%s[subscript-%d-of-%d]",
719 dim
+ 1, total_dims
);
720 len
= strlen (var
) + 1;
721 arg1
= build_string (len
, var
);
727 = build_type_variant (build_array_type (char_type_node
,
731 build_int_2 (len
, 0))),
733 TREE_CONSTANT (arg1
) = 1;
734 TREE_STATIC (arg1
) = 1;
735 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
738 /* s_rnge adds one to the element to print it, so bias against
739 that -- want to print a faithful *subscript* value. */
740 arg2
= convert (ffecom_f2c_ftnint_type_node
,
741 ffecom_2 (MINUS_EXPR
,
744 convert (TREE_TYPE (element
),
747 proc
= concat (input_filename
, "/",
748 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)),
750 len
= strlen (proc
) + 1;
751 arg3
= build_string (len
, proc
);
756 = build_type_variant (build_array_type (char_type_node
,
760 build_int_2 (len
, 0))),
762 TREE_CONSTANT (arg3
) = 1;
763 TREE_STATIC (arg3
) = 1;
764 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
767 arg4
= convert (ffecom_f2c_ftnint_type_node
,
768 build_int_2 (lineno
, 0));
770 arg1
= build_tree_list (NULL_TREE
, arg1
);
771 arg2
= build_tree_list (NULL_TREE
, arg2
);
772 arg3
= build_tree_list (NULL_TREE
, arg3
);
773 arg4
= build_tree_list (NULL_TREE
, arg4
);
774 TREE_CHAIN (arg3
) = arg4
;
775 TREE_CHAIN (arg2
) = arg3
;
776 TREE_CHAIN (arg1
) = arg2
;
780 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
782 TREE_SIDE_EFFECTS (die
) = 1;
784 element
= ffecom_3 (COND_EXPR
,
793 /* Return the computed element of an array reference.
795 `item' is NULL_TREE, or the transformed pointer to the array.
796 `expr' is the original opARRAYREF expression, which is transformed
797 if `item' is NULL_TREE.
798 `want_ptr' is non-zero if a pointer to the element, instead of
799 the element itself, is to be returned. */
802 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
804 ffebld dims
[FFECOM_dimensionsMAX
];
807 int flatten
= ffe_is_flatten_arrays ();
813 const char *array_name
;
817 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
818 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
820 array_name
= "[expr?]";
822 /* Build up ARRAY_REFs in reverse order (since we're column major
823 here in Fortran land). */
825 for (i
= 0, list
= ffebld_right (expr
);
827 ++i
, list
= ffebld_trail (list
))
829 dims
[i
] = ffebld_head (list
);
830 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
831 ffebld_kindtype (dims
[i
]));
833 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
834 && ffetype_size (type
) > ffecom_typesize_integer1_
)
835 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
836 pointers and 32-bit integers. Do the full 64-bit pointer
837 arithmetic, for codes using arrays for nonstandard heap-like
844 need_ptr
= want_ptr
|| flatten
;
849 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
851 item
= ffecom_expr (ffebld_left (expr
));
853 if (item
== error_mark_node
)
856 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
857 && ! mark_addressable (item
))
858 return error_mark_node
;
861 if (item
== error_mark_node
)
868 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
870 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
872 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
873 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
874 if (flag_bounds_check
)
875 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
877 if (element
== error_mark_node
)
880 /* Widen integral arithmetic as desired while preserving
882 tree_type
= TREE_TYPE (element
);
883 tree_type_x
= tree_type
;
885 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
886 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
887 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
889 if (TREE_TYPE (min
) != tree_type_x
)
890 min
= convert (tree_type_x
, min
);
891 if (TREE_TYPE (element
) != tree_type_x
)
892 element
= convert (tree_type_x
, element
);
894 item
= ffecom_2 (PLUS_EXPR
,
895 build_pointer_type (TREE_TYPE (array
)),
897 size_binop (MULT_EXPR
,
898 size_in_bytes (TREE_TYPE (array
)),
900 fold (build (MINUS_EXPR
,
906 item
= ffecom_1 (INDIRECT_REF
,
907 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
917 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
919 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
920 if (flag_bounds_check
)
921 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
923 if (element
== error_mark_node
)
926 /* Widen integral arithmetic as desired while preserving
928 tree_type
= TREE_TYPE (element
);
929 tree_type_x
= tree_type
;
931 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
932 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
933 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
935 element
= convert (tree_type_x
, element
);
937 item
= ffecom_2 (ARRAY_REF
,
938 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
947 /* This is like gcc's stabilize_reference -- in fact, most of the code
948 comes from that -- but it handles the situation where the reference
949 is going to have its subparts picked at, and it shouldn't change
950 (or trigger extra invocations of functions in the subtrees) due to
951 this. save_expr is a bit overzealous, because we don't need the
952 entire thing calculated and saved like a temp. So, for DECLs, no
953 change is needed, because these are stable aggregates, and ARRAY_REF
954 and such might well be stable too, but for things like calculations,
955 we do need to calculate a snapshot of a value before picking at it. */
958 ffecom_stabilize_aggregate_ (tree ref
)
961 enum tree_code code
= TREE_CODE (ref
);
968 /* No action is needed in this case. */
978 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
982 result
= build_nt (INDIRECT_REF
,
983 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
987 result
= build_nt (COMPONENT_REF
,
988 stabilize_reference (TREE_OPERAND (ref
, 0)),
989 TREE_OPERAND (ref
, 1));
993 result
= build_nt (BIT_FIELD_REF
,
994 stabilize_reference (TREE_OPERAND (ref
, 0)),
995 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
996 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
1000 result
= build_nt (ARRAY_REF
,
1001 stabilize_reference (TREE_OPERAND (ref
, 0)),
1002 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
1006 result
= build_nt (COMPOUND_EXPR
,
1007 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
1008 stabilize_reference (TREE_OPERAND (ref
, 1)));
1016 return save_expr (ref
);
1019 return error_mark_node
;
1022 TREE_TYPE (result
) = TREE_TYPE (ref
);
1023 TREE_READONLY (result
) = TREE_READONLY (ref
);
1024 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
1025 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
1030 /* A rip-off of gcc's convert.c convert_to_complex function,
1031 reworked to handle complex implemented as C structures
1032 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1035 ffecom_convert_to_complex_ (tree type
, tree expr
)
1037 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1040 assert (TREE_CODE (type
) == RECORD_TYPE
);
1042 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1044 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1046 expr
= convert (subtype
, expr
);
1047 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1048 convert (subtype
, integer_zero_node
));
1051 if (form
== RECORD_TYPE
)
1053 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1054 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1058 expr
= save_expr (expr
);
1059 return ffecom_2 (COMPLEX_EXPR
,
1062 ffecom_1 (REALPART_EXPR
,
1063 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1066 ffecom_1 (IMAGPART_EXPR
,
1067 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1072 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1073 error ("pointer value used where a complex was expected");
1075 error ("aggregate value used where a complex was expected");
1077 return ffecom_2 (COMPLEX_EXPR
, type
,
1078 convert (subtype
, integer_zero_node
),
1079 convert (subtype
, integer_zero_node
));
1082 /* Like gcc's convert(), but crashes if widening might happen. */
1085 ffecom_convert_narrow_ (type
, expr
)
1088 register tree e
= expr
;
1089 register enum tree_code code
= TREE_CODE (type
);
1091 if (type
== TREE_TYPE (e
)
1092 || TREE_CODE (e
) == ERROR_MARK
)
1094 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1095 return fold (build1 (NOP_EXPR
, type
, e
));
1096 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1097 || code
== ERROR_MARK
)
1098 return error_mark_node
;
1099 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1101 assert ("void value not ignored as it ought to be" == NULL
);
1102 return error_mark_node
;
1104 assert (code
!= VOID_TYPE
);
1105 if ((code
!= RECORD_TYPE
)
1106 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1107 assert ("converting COMPLEX to REAL" == NULL
);
1108 assert (code
!= ENUMERAL_TYPE
);
1109 if (code
== INTEGER_TYPE
)
1111 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1112 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1113 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1114 && (TYPE_PRECISION (type
)
1115 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1116 return fold (convert_to_integer (type
, e
));
1118 if (code
== POINTER_TYPE
)
1120 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1121 return fold (convert_to_pointer (type
, e
));
1123 if (code
== REAL_TYPE
)
1125 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1126 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1127 return fold (convert_to_real (type
, e
));
1129 if (code
== COMPLEX_TYPE
)
1131 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1132 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1133 return fold (convert_to_complex (type
, e
));
1135 if (code
== RECORD_TYPE
)
1137 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1138 /* Check that at least the first field name agrees. */
1139 assert (DECL_NAME (TYPE_FIELDS (type
))
1140 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1141 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1142 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1143 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1144 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1146 return fold (ffecom_convert_to_complex_ (type
, e
));
1149 assert ("conversion to non-scalar type requested" == NULL
);
1150 return error_mark_node
;
1153 /* Like gcc's convert(), but crashes if narrowing might happen. */
1156 ffecom_convert_widen_ (type
, expr
)
1159 register tree e
= expr
;
1160 register enum tree_code code
= TREE_CODE (type
);
1162 if (type
== TREE_TYPE (e
)
1163 || TREE_CODE (e
) == ERROR_MARK
)
1165 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1166 return fold (build1 (NOP_EXPR
, type
, e
));
1167 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1168 || code
== ERROR_MARK
)
1169 return error_mark_node
;
1170 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1172 assert ("void value not ignored as it ought to be" == NULL
);
1173 return error_mark_node
;
1175 assert (code
!= VOID_TYPE
);
1176 if ((code
!= RECORD_TYPE
)
1177 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1178 assert ("narrowing COMPLEX to REAL" == NULL
);
1179 assert (code
!= ENUMERAL_TYPE
);
1180 if (code
== INTEGER_TYPE
)
1182 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1183 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1184 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1185 && (TYPE_PRECISION (type
)
1186 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1187 return fold (convert_to_integer (type
, e
));
1189 if (code
== POINTER_TYPE
)
1191 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1192 return fold (convert_to_pointer (type
, e
));
1194 if (code
== REAL_TYPE
)
1196 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1197 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1198 return fold (convert_to_real (type
, e
));
1200 if (code
== COMPLEX_TYPE
)
1202 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1203 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1204 return fold (convert_to_complex (type
, e
));
1206 if (code
== RECORD_TYPE
)
1208 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1209 /* Check that at least the first field name agrees. */
1210 assert (DECL_NAME (TYPE_FIELDS (type
))
1211 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1212 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1213 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1214 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1215 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1217 return fold (ffecom_convert_to_complex_ (type
, e
));
1220 assert ("conversion to non-scalar type requested" == NULL
);
1221 return error_mark_node
;
1224 /* Handles making a COMPLEX type, either the standard
1225 (but buggy?) gbe way, or the safer (but less elegant?)
1229 ffecom_make_complex_type_ (tree subtype
)
1235 if (ffe_is_emulate_complex ())
1237 type
= make_node (RECORD_TYPE
);
1238 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1239 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1240 TYPE_FIELDS (type
) = realfield
;
1245 type
= make_node (COMPLEX_TYPE
);
1246 TREE_TYPE (type
) = subtype
;
1253 /* Chooses either the gbe or the f2c way to build a
1254 complex constant. */
1257 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1261 if (ffe_is_emulate_complex ())
1263 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1264 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1265 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1269 bothparts
= build_complex (type
, realpart
, imagpart
);
1276 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1279 tree
*plist
= &list
;
1280 tree trail
= NULL_TREE
; /* Append char length args here. */
1281 tree
*ptrail
= &trail
;
1286 tree wanted
= NULL_TREE
;
1287 static const char zed
[] = "0";
1292 while (expr
!= NULL
)
1315 wanted
= ffecom_f2c_complex_type_node
;
1319 wanted
= ffecom_f2c_doublereal_type_node
;
1323 wanted
= ffecom_f2c_doublecomplex_type_node
;
1327 wanted
= ffecom_f2c_real_type_node
;
1331 wanted
= ffecom_f2c_integer_type_node
;
1335 wanted
= ffecom_f2c_longint_type_node
;
1339 assert ("bad argstring code" == NULL
);
1345 exprh
= ffebld_head (expr
);
1349 if ((wanted
== NULL_TREE
)
1352 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1353 [ffeinfo_kindtype (ffebld_info (exprh
))])
1354 == TYPE_MODE (wanted
))))
1356 = build_tree_list (NULL_TREE
,
1357 ffecom_arg_ptr_to_expr (exprh
,
1361 item
= ffecom_arg_expr (exprh
, &length
);
1362 item
= ffecom_convert_widen_ (wanted
, item
);
1365 item
= ffecom_1 (ADDR_EXPR
,
1366 build_pointer_type (TREE_TYPE (item
)),
1370 = build_tree_list (NULL_TREE
,
1374 plist
= &TREE_CHAIN (*plist
);
1375 expr
= ffebld_trail (expr
);
1376 if (length
!= NULL_TREE
)
1378 *ptrail
= build_tree_list (NULL_TREE
, length
);
1379 ptrail
= &TREE_CHAIN (*ptrail
);
1383 /* We've run out of args in the call; if the implementation expects
1384 more, supply null pointers for them, which the implementation can
1385 check to see if an arg was omitted. */
1387 while (*c
!= '\0' && *c
!= '0')
1392 assert ("missing arg to run-time routine!" == NULL
);
1407 assert ("bad arg string code" == NULL
);
1411 = build_tree_list (NULL_TREE
,
1413 plist
= &TREE_CHAIN (*plist
);
1422 ffecom_widest_expr_type_ (ffebld list
)
1425 ffebld widest
= NULL
;
1427 ffetype widest_type
= NULL
;
1430 for (; list
!= NULL
; list
= ffebld_trail (list
))
1432 item
= ffebld_head (list
);
1435 if ((widest
!= NULL
)
1436 && (ffeinfo_basictype (ffebld_info (item
))
1437 != ffeinfo_basictype (ffebld_info (widest
))))
1439 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1440 ffeinfo_kindtype (ffebld_info (item
)));
1441 if ((widest
== FFEINFO_kindtypeNONE
)
1442 || (ffetype_size (type
)
1443 > ffetype_size (widest_type
)))
1450 assert (widest
!= NULL
);
1451 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1452 [ffeinfo_kindtype (ffebld_info (widest
))];
1453 assert (t
!= NULL_TREE
);
1457 /* Check whether a partial overlap between two expressions is possible.
1459 Can *starting* to write a portion of expr1 change the value
1460 computed (perhaps already, *partially*) by expr2?
1462 Currently, this is a concern only for a COMPLEX expr1. But if it
1463 isn't in COMMON or local EQUIVALENCE, since we don't support
1464 aliasing of arguments, it isn't a concern. */
1467 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1472 switch (ffebld_op (expr1
))
1474 case FFEBLD_opSYMTER
:
1475 sym
= ffebld_symter (expr1
);
1478 case FFEBLD_opARRAYREF
:
1479 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1481 sym
= ffebld_symter (ffebld_left (expr1
));
1488 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1489 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1490 || ! (st
= ffesymbol_storage (sym
))
1491 || ! ffestorag_parent (st
)))
1494 /* It's in COMMON or local EQUIVALENCE. */
1499 /* Check whether dest and source might overlap. ffebld versions of these
1500 might or might not be passed, will be NULL if not.
1502 The test is really whether source_tree is modifiable and, if modified,
1503 might overlap destination such that the value(s) in the destination might
1504 change before it is finally modified. dest_* are the canonized
1505 destination itself. */
1508 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1509 tree source_tree
, ffebld source UNUSED
,
1517 if (source_tree
== NULL_TREE
)
1520 switch (TREE_CODE (source_tree
))
1523 case IDENTIFIER_NODE
:
1534 case TRUNC_DIV_EXPR
:
1536 case FLOOR_DIV_EXPR
:
1537 case ROUND_DIV_EXPR
:
1538 case TRUNC_MOD_EXPR
:
1540 case FLOOR_MOD_EXPR
:
1541 case ROUND_MOD_EXPR
:
1543 case EXACT_DIV_EXPR
:
1544 case FIX_TRUNC_EXPR
:
1546 case FIX_FLOOR_EXPR
:
1547 case FIX_ROUND_EXPR
:
1561 case BIT_ANDTC_EXPR
:
1563 case TRUTH_ANDIF_EXPR
:
1564 case TRUTH_ORIF_EXPR
:
1565 case TRUTH_AND_EXPR
:
1567 case TRUTH_XOR_EXPR
:
1568 case TRUTH_NOT_EXPR
:
1584 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1585 TREE_OPERAND (source_tree
, 1), NULL
,
1589 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1590 TREE_OPERAND (source_tree
, 0), NULL
,
1595 case NON_LVALUE_EXPR
:
1597 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1600 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1602 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1607 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1608 TREE_OPERAND (source_tree
, 1), NULL
,
1610 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1611 TREE_OPERAND (source_tree
, 2), NULL
,
1616 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1618 TREE_OPERAND (source_tree
, 0));
1622 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1625 source_decl
= source_tree
;
1626 source_offset
= bitsize_zero_node
;
1627 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1631 case REFERENCE_EXPR
:
1632 case PREDECREMENT_EXPR
:
1633 case PREINCREMENT_EXPR
:
1634 case POSTDECREMENT_EXPR
:
1635 case POSTINCREMENT_EXPR
:
1643 /* Come here when source_decl, source_offset, and source_size filled
1644 in appropriately. */
1646 if (source_decl
== NULL_TREE
)
1647 return FALSE
; /* No decl involved, so no overlap. */
1649 if (source_decl
!= dest_decl
)
1650 return FALSE
; /* Different decl, no overlap. */
1652 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1653 return TRUE
; /* Assignment into entire assumed-size
1654 array? Shouldn't happen.... */
1656 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1657 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1659 convert (TREE_TYPE (dest_offset
),
1661 convert (TREE_TYPE (dest_offset
),
1664 if (integer_onep (t
))
1665 return FALSE
; /* Destination precedes source. */
1668 || (source_size
== NULL_TREE
)
1669 || (TREE_CODE (source_size
) == ERROR_MARK
)
1670 || integer_zerop (source_size
))
1671 return TRUE
; /* No way to tell if dest follows source. */
1673 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1674 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1676 convert (TREE_TYPE (source_offset
),
1678 convert (TREE_TYPE (source_offset
),
1681 if (integer_onep (t
))
1682 return FALSE
; /* Destination follows source. */
1684 return TRUE
; /* Destination and source overlap. */
1687 /* Check whether dest might overlap any of a list of arguments or is
1688 in a COMMON area the callee might know about (and thus modify). */
1691 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1692 tree args
, tree callee_commons
,
1700 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1703 if (dest_decl
== NULL_TREE
)
1704 return FALSE
; /* Seems unlikely! */
1706 /* If the decl cannot be determined reliably, or if its in COMMON
1707 and the callee isn't known to not futz with COMMON via other
1708 means, overlap might happen. */
1710 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1711 || ((callee_commons
!= NULL_TREE
)
1712 && TREE_PUBLIC (dest_decl
)))
1715 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1717 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1718 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1719 arg
, NULL
, scalar_args
))
1726 /* Build a string for a variable name as used by NAMELIST. This means that
1727 if we're using the f2c library, we build an uppercase string, since
1731 ffecom_build_f2c_string_ (int i
, const char *s
)
1733 if (!ffe_is_f2c_library ())
1734 return build_string (i
, s
);
1743 if (((size_t) i
) > ARRAY_SIZE (space
))
1744 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1748 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1752 t
= build_string (i
, tmp
);
1754 if (((size_t) i
) > ARRAY_SIZE (space
))
1755 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1761 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1762 type to just get whatever the function returns), handling the
1763 f2c value-returning convention, if required, by prepending
1764 to the arglist a pointer to a temporary to receive the return value. */
1767 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1768 tree type
, tree args
, tree dest_tree
,
1769 ffebld dest
, bool *dest_used
, tree callee_commons
,
1770 bool scalar_args
, tree hook
)
1775 if (dest_used
!= NULL
)
1780 if ((dest_used
== NULL
)
1782 || (ffeinfo_basictype (ffebld_info (dest
))
1783 != FFEINFO_basictypeCOMPLEX
)
1784 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1785 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1786 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1791 tempvar
= ffecom_make_tempvar (ffecom_tree_type
1792 [FFEINFO_basictypeCOMPLEX
][kt
],
1793 FFETARGET_charactersizeNONE
,
1803 tempvar
= dest_tree
;
1808 = build_tree_list (NULL_TREE
,
1809 ffecom_1 (ADDR_EXPR
,
1810 build_pointer_type (TREE_TYPE (tempvar
)),
1812 TREE_CHAIN (item
) = args
;
1814 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1817 if (tempvar
!= dest_tree
)
1818 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1821 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1824 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1825 item
= ffecom_convert_narrow_ (type
, item
);
1830 /* Given two arguments, transform them and make a call to the given
1831 function via ffecom_call_. */
1834 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1835 tree type
, ffebld left
, ffebld right
,
1836 tree dest_tree
, ffebld dest
, bool *dest_used
,
1837 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1846 /* Pass arguments by reference. */
1847 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1848 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1852 /* Pass arguments by value. */
1853 left_tree
= ffecom_arg_expr (left
, &left_length
);
1854 right_tree
= ffecom_arg_expr (right
, &right_length
);
1858 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1859 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1860 TREE_CHAIN (left_tree
) = right_tree
;
1862 if (left_length
!= NULL_TREE
)
1864 left_length
= build_tree_list (NULL_TREE
, left_length
);
1865 TREE_CHAIN (right_tree
) = left_length
;
1868 if (right_length
!= NULL_TREE
)
1870 right_length
= build_tree_list (NULL_TREE
, right_length
);
1871 if (left_length
!= NULL_TREE
)
1872 TREE_CHAIN (left_length
) = right_length
;
1874 TREE_CHAIN (right_tree
) = right_length
;
1877 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1878 dest_tree
, dest
, dest_used
, callee_commons
,
1882 /* Return ptr/length args for char subexpression
1884 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1885 subexpressions by constructing the appropriate trees for the ptr-to-
1886 character-text and length-of-character-text arguments in a calling
1889 Note that if with_null is TRUE, and the expression is an opCONTER,
1890 a null byte is appended to the string. */
1893 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1897 ffetargetCharacter1 val
;
1898 ffetargetCharacterSize newlen
;
1900 switch (ffebld_op (expr
))
1902 case FFEBLD_opCONTER
:
1903 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1904 newlen
= ffetarget_length_character1 (val
);
1907 /* Begin FFETARGET-NULL-KLUDGE. */
1911 *length
= build_int_2 (newlen
, 0);
1912 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1913 high
= build_int_2 (newlen
, 0);
1914 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1915 item
= build_string (newlen
,
1916 ffetarget_text_character1 (val
));
1917 /* End FFETARGET-NULL-KLUDGE. */
1919 = build_type_variant
1923 (ffecom_f2c_ftnlen_type_node
,
1924 ffecom_f2c_ftnlen_one_node
,
1927 TREE_CONSTANT (item
) = 1;
1928 TREE_STATIC (item
) = 1;
1929 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1933 case FFEBLD_opSYMTER
:
1935 ffesymbol s
= ffebld_symter (expr
);
1937 item
= ffesymbol_hook (s
).decl_tree
;
1938 if (item
== NULL_TREE
)
1940 s
= ffecom_sym_transform_ (s
);
1941 item
= ffesymbol_hook (s
).decl_tree
;
1943 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1945 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1946 *length
= ffesymbol_hook (s
).length_tree
;
1949 *length
= build_int_2 (ffesymbol_size (s
), 0);
1950 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1953 else if (item
== error_mark_node
)
1954 *length
= error_mark_node
;
1956 /* FFEINFO_kindFUNCTION. */
1957 *length
= NULL_TREE
;
1958 if (!ffesymbol_hook (s
).addr
1959 && (item
!= error_mark_node
))
1960 item
= ffecom_1 (ADDR_EXPR
,
1961 build_pointer_type (TREE_TYPE (item
)),
1966 case FFEBLD_opARRAYREF
:
1968 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1970 if (item
== error_mark_node
|| *length
== error_mark_node
)
1972 item
= *length
= error_mark_node
;
1976 item
= ffecom_arrayref_ (item
, expr
, 1);
1980 case FFEBLD_opSUBSTR
:
1984 ffebld thing
= ffebld_right (expr
);
1987 const char *char_name
;
1991 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1992 start
= ffebld_head (thing
);
1993 thing
= ffebld_trail (thing
);
1994 assert (ffebld_trail (thing
) == NULL
);
1995 end
= ffebld_head (thing
);
1997 /* Determine name for pretty-printing range-check errors. */
1998 for (left_symter
= ffebld_left (expr
);
1999 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2000 left_symter
= ffebld_left (left_symter
))
2002 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2003 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2005 char_name
= "[expr?]";
2007 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2009 if (item
== error_mark_node
|| *length
== error_mark_node
)
2011 item
= *length
= error_mark_node
;
2015 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2017 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2025 end_tree
= ffecom_expr (end
);
2026 if (flag_bounds_check
)
2027 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2029 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2032 if (end_tree
== error_mark_node
)
2034 item
= *length
= error_mark_node
;
2043 start_tree
= ffecom_expr (start
);
2044 if (flag_bounds_check
)
2045 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2047 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2050 if (start_tree
== error_mark_node
)
2052 item
= *length
= error_mark_node
;
2056 start_tree
= ffecom_save_tree (start_tree
);
2058 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2060 ffecom_2 (MINUS_EXPR
,
2061 TREE_TYPE (start_tree
),
2063 ffecom_f2c_ftnlen_one_node
));
2067 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2068 ffecom_f2c_ftnlen_one_node
,
2069 ffecom_2 (MINUS_EXPR
,
2070 ffecom_f2c_ftnlen_type_node
,
2076 end_tree
= ffecom_expr (end
);
2077 if (flag_bounds_check
)
2078 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2080 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2083 if (end_tree
== error_mark_node
)
2085 item
= *length
= error_mark_node
;
2089 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2090 ffecom_f2c_ftnlen_one_node
,
2091 ffecom_2 (MINUS_EXPR
,
2092 ffecom_f2c_ftnlen_type_node
,
2093 end_tree
, start_tree
));
2099 case FFEBLD_opFUNCREF
:
2101 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2104 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2107 if (size
== FFETARGET_charactersizeNONE
)
2108 /* ~~Kludge alert! This should someday be fixed. */
2111 *length
= build_int_2 (size
, 0);
2112 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2114 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2115 == FFEINFO_whereINTRINSIC
)
2119 /* Invocation of an intrinsic returning CHARACTER*1. */
2120 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2124 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2125 assert (ix
!= FFECOM_gfrt
);
2126 item
= ffecom_gfrt_tree_ (ix
);
2131 item
= ffesymbol_hook (s
).decl_tree
;
2132 if (item
== NULL_TREE
)
2134 s
= ffecom_sym_transform_ (s
);
2135 item
= ffesymbol_hook (s
).decl_tree
;
2137 if (item
== error_mark_node
)
2139 item
= *length
= error_mark_node
;
2143 if (!ffesymbol_hook (s
).addr
)
2144 item
= ffecom_1_fn (item
);
2148 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
2150 tempvar
= ffebld_nonter_hook (expr
);
2153 tempvar
= ffecom_1 (ADDR_EXPR
,
2154 build_pointer_type (TREE_TYPE (tempvar
)),
2157 args
= build_tree_list (NULL_TREE
, tempvar
);
2159 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2160 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2163 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2164 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2166 TREE_CHAIN (TREE_CHAIN (args
))
2167 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2168 ffebld_right (expr
));
2172 TREE_CHAIN (TREE_CHAIN (args
))
2173 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2177 item
= ffecom_3s (CALL_EXPR
,
2178 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2179 item
, args
, NULL_TREE
);
2180 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2185 case FFEBLD_opCONVERT
:
2187 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2189 if (item
== error_mark_node
|| *length
== error_mark_node
)
2191 item
= *length
= error_mark_node
;
2195 if ((ffebld_size_known (ffebld_left (expr
))
2196 == FFETARGET_charactersizeNONE
)
2197 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2198 { /* Possible blank-padding needed, copy into
2205 tempvar
= ffecom_make_tempvar (char_type_node
,
2206 ffebld_size (expr
), -1);
2208 tempvar
= ffebld_nonter_hook (expr
);
2211 tempvar
= ffecom_1 (ADDR_EXPR
,
2212 build_pointer_type (TREE_TYPE (tempvar
)),
2215 newlen
= build_int_2 (ffebld_size (expr
), 0);
2216 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2218 args
= build_tree_list (NULL_TREE
, tempvar
);
2219 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2220 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2221 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2222 = build_tree_list (NULL_TREE
, *length
);
2224 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2225 TREE_SIDE_EFFECTS (item
) = 1;
2226 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2231 { /* Just truncate the length. */
2232 *length
= build_int_2 (ffebld_size (expr
), 0);
2233 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2238 assert ("bad op for single char arg expr" == NULL
);
2246 /* Check the size of the type to be sure it doesn't overflow the
2247 "portable" capacities of the compiler back end. `dummy' types
2248 can generally overflow the normal sizes as long as the computations
2249 themselves don't overflow. A particular target of the back end
2250 must still enforce its size requirements, though, and the back
2251 end takes care of this in stor-layout.c. */
2254 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2256 if (TREE_CODE (type
) == ERROR_MARK
)
2259 if (TYPE_SIZE (type
) == NULL_TREE
)
2262 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2265 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2266 || (!dummy
&& TREE_OVERFLOW (TYPE_SIZE (type
))))
2268 ffebad_start (FFEBAD_ARRAY_LARGE
);
2269 ffebad_string (ffesymbol_text (s
));
2270 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2273 return error_mark_node
;
2279 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2280 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2281 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2284 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2286 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2291 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2292 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2295 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2296 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2297 ffesymbol_text (s
));
2299 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2300 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2301 DECL_ARTIFICIAL (tlen
) = 1;
2304 if (sz
== FFETARGET_charactersizeNONE
)
2306 assert (tlen
!= NULL_TREE
);
2307 highval
= variable_size (tlen
);
2311 highval
= build_int_2 (sz
, 0);
2312 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2315 type
= build_array_type (type
,
2316 build_range_type (ffecom_f2c_ftnlen_type_node
,
2317 ffecom_f2c_ftnlen_one_node
,
2324 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2326 ffecomConcatList_ catlist;
2327 ffebld expr; // expr of CHARACTER basictype.
2328 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2329 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2331 Scans expr for character subexpressions, updates and returns catlist
2334 static ffecomConcatList_
2335 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2336 ffetargetCharacterSize max
)
2338 ffetargetCharacterSize sz
;
2345 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2346 return catlist
; /* Don't append any more items. */
2348 switch (ffebld_op (expr
))
2350 case FFEBLD_opCONTER
:
2351 case FFEBLD_opSYMTER
:
2352 case FFEBLD_opARRAYREF
:
2353 case FFEBLD_opFUNCREF
:
2354 case FFEBLD_opSUBSTR
:
2355 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2356 if they don't need to preserve it. */
2357 if (catlist
.count
== catlist
.max
)
2358 { /* Make a (larger) list. */
2362 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2363 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2364 newmax
* sizeof (newx
[0]));
2365 if (catlist
.max
!= 0)
2367 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2368 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2369 catlist
.max
* sizeof (newx
[0]));
2371 catlist
.max
= newmax
;
2372 catlist
.exprs
= newx
;
2374 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2375 catlist
.minlen
+= sz
;
2377 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2378 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2379 catlist
.maxlen
= sz
;
2381 catlist
.maxlen
+= sz
;
2382 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2383 { /* This item overlaps (or is beyond) the end
2384 of the destination. */
2385 switch (ffebld_op (expr
))
2387 case FFEBLD_opCONTER
:
2388 case FFEBLD_opSYMTER
:
2389 case FFEBLD_opARRAYREF
:
2390 case FFEBLD_opFUNCREF
:
2391 case FFEBLD_opSUBSTR
:
2392 /* ~~Do useful truncations here. */
2396 assert ("op changed or inconsistent switches!" == NULL
);
2400 catlist
.exprs
[catlist
.count
++] = expr
;
2403 case FFEBLD_opPAREN
:
2404 expr
= ffebld_left (expr
);
2405 goto recurse
; /* :::::::::::::::::::: */
2407 case FFEBLD_opCONCATENATE
:
2408 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2409 expr
= ffebld_right (expr
);
2410 goto recurse
; /* :::::::::::::::::::: */
2412 #if 0 /* Breaks passing small actual arg to larger
2413 dummy arg of sfunc */
2414 case FFEBLD_opCONVERT
:
2415 expr
= ffebld_left (expr
);
2417 ffetargetCharacterSize cmax
;
2419 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2421 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2424 goto recurse
; /* :::::::::::::::::::: */
2431 assert ("bad op in _gather_" == NULL
);
2436 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2438 ffecomConcatList_ catlist;
2439 ffecom_concat_list_kill_(catlist);
2441 Anything allocated within the list info is deallocated. */
2444 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2446 if (catlist
.max
!= 0)
2447 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2448 catlist
.max
* sizeof (catlist
.exprs
[0]));
2451 /* Make list of concatenated string exprs.
2453 Returns a flattened list of concatenated subexpressions given a
2454 tree of such expressions. */
2456 static ffecomConcatList_
2457 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2459 ffecomConcatList_ catlist
;
2461 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2462 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2465 /* Provide some kind of useful info on member of aggregate area,
2466 since current g77/gcc technology does not provide debug info
2467 on these members. */
2470 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2471 tree member_type UNUSED
, ffetargetOffset offset
)
2481 for (type_id
= member_type
;
2482 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2485 switch (TREE_CODE (type_id
))
2489 type_id
= TYPE_NAME (type_id
);
2494 type_id
= TREE_TYPE (type_id
);
2498 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2499 type_id
= error_mark_node
;
2505 if (ffecom_transform_only_dummies_
2506 || !ffe_is_debug_kludge ())
2507 return; /* Can't do this yet, maybe later. */
2510 + strlen (aggr_type
)
2511 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2513 + IDENTIFIER_LENGTH (type_id
);
2516 if (((size_t) len
) >= ARRAY_SIZE (space
))
2517 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2521 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2523 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2526 value
= build_string (len
, buff
);
2528 = build_type_variant (build_array_type (char_type_node
,
2532 build_int_2 (strlen (buff
), 0))),
2534 decl
= build_decl (VAR_DECL
,
2535 ffecom_get_identifier_ (ffesymbol_text (member
)),
2537 TREE_CONSTANT (decl
) = 1;
2538 TREE_STATIC (decl
) = 1;
2539 DECL_INITIAL (decl
) = error_mark_node
;
2540 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2541 decl
= start_decl (decl
, FALSE
);
2542 finish_decl (decl
, value
, FALSE
);
2544 if (buff
!= &space
[0])
2545 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2548 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2550 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2551 int i; // entry# for this entrypoint (used by master fn)
2552 ffecom_do_entrypoint_(s,i);
2554 Makes a public entry point that calls our private master fn (already
2558 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2561 tree type
; /* Type of function. */
2562 tree multi_retval
; /* Var holding return value (union). */
2563 tree result
; /* Var holding result. */
2564 ffeinfoBasictype bt
;
2568 bool charfunc
; /* All entry points return same type
2570 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2571 bool multi
; /* Master fn has multiple return types. */
2572 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2573 int old_lineno
= lineno
;
2574 const char *old_input_filename
= input_filename
;
2576 input_filename
= ffesymbol_where_filename (fn
);
2577 lineno
= ffesymbol_where_filelinenum (fn
);
2579 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2581 switch (ffecom_primary_entry_kind_
)
2583 case FFEINFO_kindFUNCTION
:
2585 /* Determine actual return type for function. */
2587 gt
= FFEGLOBAL_typeFUNC
;
2588 bt
= ffesymbol_basictype (fn
);
2589 kt
= ffesymbol_kindtype (fn
);
2590 if (bt
== FFEINFO_basictypeNONE
)
2592 ffeimplic_establish_symbol (fn
);
2593 if (ffesymbol_funcresult (fn
) != NULL
)
2594 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2595 bt
= ffesymbol_basictype (fn
);
2596 kt
= ffesymbol_kindtype (fn
);
2599 if (bt
== FFEINFO_basictypeCHARACTER
)
2600 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2601 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2602 && ffesymbol_is_f2c (fn
))
2603 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2605 charfunc
= cmplxfunc
= FALSE
;
2608 type
= ffecom_tree_fun_type_void
;
2609 else if (ffesymbol_is_f2c (fn
))
2610 type
= ffecom_tree_fun_type
[bt
][kt
];
2612 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2614 if ((type
== NULL_TREE
)
2615 || (TREE_TYPE (type
) == NULL_TREE
))
2616 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2618 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2621 case FFEINFO_kindSUBROUTINE
:
2622 gt
= FFEGLOBAL_typeSUBR
;
2623 bt
= FFEINFO_basictypeNONE
;
2624 kt
= FFEINFO_kindtypeNONE
;
2625 if (ffecom_is_altreturning_
)
2626 { /* Am _I_ altreturning? */
2627 for (item
= ffesymbol_dummyargs (fn
);
2629 item
= ffebld_trail (item
))
2631 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2633 altreturning
= TRUE
;
2638 type
= ffecom_tree_subr_type
;
2640 type
= ffecom_tree_fun_type_void
;
2643 type
= ffecom_tree_fun_type_void
;
2650 assert ("say what??" == NULL
);
2652 case FFEINFO_kindANY
:
2653 gt
= FFEGLOBAL_typeANY
;
2654 bt
= FFEINFO_basictypeNONE
;
2655 kt
= FFEINFO_kindtypeNONE
;
2656 type
= error_mark_node
;
2663 /* build_decl uses the current lineno and input_filename to set the decl
2664 source info. So, I've putzed with ffestd and ffeste code to update that
2665 source info to point to the appropriate statement just before calling
2666 ffecom_do_entrypoint (which calls this fn). */
2668 start_function (ffecom_get_external_identifier_ (fn
),
2670 0, /* nested/inline */
2671 1); /* TREE_PUBLIC */
2673 if (((g
= ffesymbol_global (fn
)) != NULL
)
2674 && ((ffeglobal_type (g
) == gt
)
2675 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2677 ffeglobal_set_hook (g
, current_function_decl
);
2680 /* Reset args in master arg list so they get retransitioned. */
2682 for (item
= ffecom_master_arglist_
;
2684 item
= ffebld_trail (item
))
2689 arg
= ffebld_head (item
);
2690 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2691 continue; /* Alternate return or some such thing. */
2692 s
= ffebld_symter (arg
);
2693 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2694 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2697 /* Build dummy arg list for this entry point. */
2699 if (charfunc
|| cmplxfunc
)
2700 { /* Prepend arg for where result goes. */
2705 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2707 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2709 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2711 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2714 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2716 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2718 type
= build_pointer_type (type
);
2719 result
= build_decl (PARM_DECL
, result
, type
);
2721 push_parm_decl (result
);
2722 ffecom_func_result_
= result
;
2726 push_parm_decl (length
);
2727 ffecom_func_length_
= length
;
2731 result
= DECL_RESULT (current_function_decl
);
2733 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2735 store_parm_decls (0);
2737 ffecom_start_compstmt ();
2738 /* Disallow temp vars at this level. */
2739 current_binding_level
->prep_state
= 2;
2741 /* Make local var to hold return type for multi-type master fn. */
2745 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2747 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2748 ffecom_multi_type_node_
);
2749 multi_retval
= start_decl (multi_retval
, FALSE
);
2750 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2753 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2755 /* Here we emit the actual code for the entry point. */
2761 tree arglist
= NULL_TREE
;
2762 tree
*plist
= &arglist
;
2768 /* Prepare actual arg list based on master arg list. */
2770 for (list
= ffecom_master_arglist_
;
2772 list
= ffebld_trail (list
))
2774 arg
= ffebld_head (list
);
2775 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2777 s
= ffebld_symter (arg
);
2778 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2779 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2780 actarg
= null_pointer_node
; /* We don't have this arg. */
2782 actarg
= ffesymbol_hook (s
).decl_tree
;
2783 *plist
= build_tree_list (NULL_TREE
, actarg
);
2784 plist
= &TREE_CHAIN (*plist
);
2787 /* This code appends the length arguments for character
2788 variables/arrays. */
2790 for (list
= ffecom_master_arglist_
;
2792 list
= ffebld_trail (list
))
2794 arg
= ffebld_head (list
);
2795 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2797 s
= ffebld_symter (arg
);
2798 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2799 continue; /* Only looking for CHARACTER arguments. */
2800 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2801 continue; /* Only looking for variables and arrays. */
2802 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2803 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2804 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2806 actarg
= ffesymbol_hook (s
).length_tree
;
2807 *plist
= build_tree_list (NULL_TREE
, actarg
);
2808 plist
= &TREE_CHAIN (*plist
);
2811 /* Prepend character-value return info to actual arg list. */
2815 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2816 TREE_CHAIN (prepend
)
2817 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2818 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2822 /* Prepend multi-type return value to actual arg list. */
2827 = build_tree_list (NULL_TREE
,
2828 ffecom_1 (ADDR_EXPR
,
2829 build_pointer_type (TREE_TYPE (multi_retval
)),
2831 TREE_CHAIN (prepend
) = arglist
;
2835 /* Prepend my entry-point number to the actual arg list. */
2837 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2838 TREE_CHAIN (prepend
) = arglist
;
2841 /* Build the call to the master function. */
2843 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2844 call
= ffecom_3s (CALL_EXPR
,
2845 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2846 master_fn
, arglist
, NULL_TREE
);
2848 /* Decide whether the master function is a function or subroutine, and
2849 handle the return value for my entry point. */
2851 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2854 expand_expr_stmt (call
);
2855 expand_null_return ();
2857 else if (multi
&& cmplxfunc
)
2859 expand_expr_stmt (call
);
2861 = ffecom_1 (INDIRECT_REF
,
2862 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2864 result
= ffecom_modify (NULL_TREE
, result
,
2865 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2867 ffecom_multi_fields_
[bt
][kt
]));
2868 expand_expr_stmt (result
);
2869 expand_null_return ();
2873 expand_expr_stmt (call
);
2875 = ffecom_modify (NULL_TREE
, result
,
2876 convert (TREE_TYPE (result
),
2877 ffecom_2 (COMPONENT_REF
,
2878 ffecom_tree_type
[bt
][kt
],
2880 ffecom_multi_fields_
[bt
][kt
])));
2881 expand_return (result
);
2886 = ffecom_1 (INDIRECT_REF
,
2887 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2889 result
= ffecom_modify (NULL_TREE
, result
, call
);
2890 expand_expr_stmt (result
);
2891 expand_null_return ();
2895 result
= ffecom_modify (NULL_TREE
,
2897 convert (TREE_TYPE (result
),
2899 expand_return (result
);
2903 ffecom_end_compstmt ();
2905 finish_function (0);
2907 lineno
= old_lineno
;
2908 input_filename
= old_input_filename
;
2910 ffecom_doing_entry_
= FALSE
;
2913 /* Transform expr into gcc tree with possible destination
2915 Recursive descent on expr while making corresponding tree nodes and
2916 attaching type info and such. If destination supplied and compatible
2917 with temporary that would be made in certain cases, temporary isn't
2918 made, destination used instead, and dest_used flag set TRUE. */
2921 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2922 bool *dest_used
, bool assignp
, bool widenp
)
2927 ffeinfoBasictype bt
;
2930 tree dt
; /* decl_tree for an ffesymbol. */
2931 tree tree_type
, tree_type_x
;
2934 enum tree_code code
;
2936 assert (expr
!= NULL
);
2938 if (dest_used
!= NULL
)
2941 bt
= ffeinfo_basictype (ffebld_info (expr
));
2942 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2943 tree_type
= ffecom_tree_type
[bt
][kt
];
2945 /* Widen integral arithmetic as desired while preserving signedness. */
2946 tree_type_x
= NULL_TREE
;
2947 if (widenp
&& tree_type
2948 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2949 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2950 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2952 switch (ffebld_op (expr
))
2954 case FFEBLD_opACCTER
:
2957 ffebit bits
= ffebld_accter_bits (expr
);
2958 ffetargetOffset source_offset
= 0;
2959 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
2962 assert (dest_offset
== 0
2963 || (bt
== FFEINFO_basictypeCHARACTER
2964 && kt
== FFEINFO_kindtypeCHARACTER1
));
2969 ffebldConstantUnion cu
;
2972 ffebldConstantArray ca
= ffebld_accter (expr
);
2974 ffebit_test (bits
, source_offset
, &value
, &length
);
2980 for (i
= 0; i
< length
; ++i
)
2982 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2985 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2988 && dest_offset
!= 0)
2989 purpose
= build_int_2 (dest_offset
, 0);
2991 purpose
= NULL_TREE
;
2993 if (list
== NULL_TREE
)
2994 list
= item
= build_tree_list (purpose
, t
);
2997 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2998 item
= TREE_CHAIN (item
);
3002 source_offset
+= length
;
3003 dest_offset
+= length
;
3007 item
= build_int_2 ((ffebld_accter_size (expr
)
3008 + ffebld_accter_pad (expr
)) - 1, 0);
3009 ffebit_kill (ffebld_accter_bits (expr
));
3010 TREE_TYPE (item
) = ffecom_integer_type_node
;
3014 build_range_type (ffecom_integer_type_node
,
3015 ffecom_integer_zero_node
,
3017 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3018 TREE_CONSTANT (list
) = 1;
3019 TREE_STATIC (list
) = 1;
3022 case FFEBLD_opARRTER
:
3027 if (ffebld_arrter_pad (expr
) == 0)
3031 assert (bt
== FFEINFO_basictypeCHARACTER
3032 && kt
== FFEINFO_kindtypeCHARACTER1
);
3034 /* Becomes PURPOSE first time through loop. */
3035 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3038 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3040 ffebldConstantUnion cu
3041 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3043 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3045 if (list
== NULL_TREE
)
3046 /* Assume item is PURPOSE first time through loop. */
3047 list
= item
= build_tree_list (item
, t
);
3050 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3051 item
= TREE_CHAIN (item
);
3056 item
= build_int_2 ((ffebld_arrter_size (expr
)
3057 + ffebld_arrter_pad (expr
)) - 1, 0);
3058 TREE_TYPE (item
) = ffecom_integer_type_node
;
3062 build_range_type (ffecom_integer_type_node
,
3063 ffecom_integer_zero_node
,
3065 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3066 TREE_CONSTANT (list
) = 1;
3067 TREE_STATIC (list
) = 1;
3070 case FFEBLD_opCONTER
:
3071 assert (ffebld_conter_pad (expr
) == 0);
3073 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3077 case FFEBLD_opSYMTER
:
3078 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3079 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3080 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3081 s
= ffebld_symter (expr
);
3082 t
= ffesymbol_hook (s
).decl_tree
;
3085 { /* ASSIGN'ed-label expr. */
3086 if (ffe_is_ugly_assign ())
3088 /* User explicitly wants ASSIGN'ed variables to be at the same
3089 memory address as the variables when used in non-ASSIGN
3090 contexts. That can make old, arcane, non-standard code
3091 work, but don't try to do it when a pointer wouldn't fit
3092 in the normal variable (take other approach, and warn,
3097 s
= ffecom_sym_transform_ (s
);
3098 t
= ffesymbol_hook (s
).decl_tree
;
3099 assert (t
!= NULL_TREE
);
3102 if (t
== error_mark_node
)
3105 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3106 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3108 if (ffesymbol_hook (s
).addr
)
3109 t
= ffecom_1 (INDIRECT_REF
,
3110 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3114 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3116 /* xgettext:no-c-format */
3117 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3118 FFEBAD_severityWARNING
);
3119 ffebad_string (ffesymbol_text (s
));
3120 ffebad_here (0, ffesymbol_where_line (s
),
3121 ffesymbol_where_column (s
));
3126 /* Don't use the normal variable's tree for ASSIGN, though mark
3127 it as in the system header (housekeeping). Use an explicit,
3128 specially created sibling that is known to be wide enough
3129 to hold pointers to labels. */
3132 && TREE_CODE (t
) == VAR_DECL
)
3133 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3135 t
= ffesymbol_hook (s
).assign_tree
;
3138 s
= ffecom_sym_transform_assign_ (s
);
3139 t
= ffesymbol_hook (s
).assign_tree
;
3140 assert (t
!= NULL_TREE
);
3147 s
= ffecom_sym_transform_ (s
);
3148 t
= ffesymbol_hook (s
).decl_tree
;
3149 assert (t
!= NULL_TREE
);
3151 if (ffesymbol_hook (s
).addr
)
3152 t
= ffecom_1 (INDIRECT_REF
,
3153 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3157 case FFEBLD_opARRAYREF
:
3158 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3160 case FFEBLD_opUPLUS
:
3161 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3162 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3164 case FFEBLD_opPAREN
:
3165 /* ~~~Make sure Fortran rules respected here */
3166 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3167 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3169 case FFEBLD_opUMINUS
:
3170 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3173 tree_type
= tree_type_x
;
3174 left
= convert (tree_type
, left
);
3176 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3179 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3180 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3183 tree_type
= tree_type_x
;
3184 left
= convert (tree_type
, left
);
3185 right
= convert (tree_type
, right
);
3187 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3189 case FFEBLD_opSUBTRACT
:
3190 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3191 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3194 tree_type
= tree_type_x
;
3195 left
= convert (tree_type
, left
);
3196 right
= convert (tree_type
, right
);
3198 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3200 case FFEBLD_opMULTIPLY
:
3201 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3202 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3205 tree_type
= tree_type_x
;
3206 left
= convert (tree_type
, left
);
3207 right
= convert (tree_type
, right
);
3209 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3211 case FFEBLD_opDIVIDE
:
3212 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3213 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3216 tree_type
= tree_type_x
;
3217 left
= convert (tree_type
, left
);
3218 right
= convert (tree_type
, right
);
3220 return ffecom_tree_divide_ (tree_type
, left
, right
,
3221 dest_tree
, dest
, dest_used
,
3222 ffebld_nonter_hook (expr
));
3224 case FFEBLD_opPOWER
:
3226 ffebld left
= ffebld_left (expr
);
3227 ffebld right
= ffebld_right (expr
);
3229 ffeinfoKindtype rtkt
;
3230 ffeinfoKindtype ltkt
;
3233 switch (ffeinfo_basictype (ffebld_info (right
)))
3236 case FFEINFO_basictypeINTEGER
:
3239 item
= ffecom_expr_power_integer_ (expr
);
3240 if (item
!= NULL_TREE
)
3244 rtkt
= FFEINFO_kindtypeINTEGER1
;
3245 switch (ffeinfo_basictype (ffebld_info (left
)))
3247 case FFEINFO_basictypeINTEGER
:
3248 if ((ffeinfo_kindtype (ffebld_info (left
))
3249 == FFEINFO_kindtypeINTEGER4
)
3250 || (ffeinfo_kindtype (ffebld_info (right
))
3251 == FFEINFO_kindtypeINTEGER4
))
3253 code
= FFECOM_gfrtPOW_QQ
;
3254 ltkt
= FFEINFO_kindtypeINTEGER4
;
3255 rtkt
= FFEINFO_kindtypeINTEGER4
;
3259 code
= FFECOM_gfrtPOW_II
;
3260 ltkt
= FFEINFO_kindtypeINTEGER1
;
3264 case FFEINFO_basictypeREAL
:
3265 if (ffeinfo_kindtype (ffebld_info (left
))
3266 == FFEINFO_kindtypeREAL1
)
3268 code
= FFECOM_gfrtPOW_RI
;
3269 ltkt
= FFEINFO_kindtypeREAL1
;
3273 code
= FFECOM_gfrtPOW_DI
;
3274 ltkt
= FFEINFO_kindtypeREAL2
;
3278 case FFEINFO_basictypeCOMPLEX
:
3279 if (ffeinfo_kindtype (ffebld_info (left
))
3280 == FFEINFO_kindtypeREAL1
)
3282 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3283 ltkt
= FFEINFO_kindtypeREAL1
;
3287 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3288 ltkt
= FFEINFO_kindtypeREAL2
;
3293 assert ("bad pow_*i" == NULL
);
3294 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3295 ltkt
= FFEINFO_kindtypeREAL1
;
3298 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3299 left
= ffeexpr_convert (left
, NULL
, NULL
,
3300 ffeinfo_basictype (ffebld_info (left
)),
3302 FFETARGET_charactersizeNONE
,
3303 FFEEXPR_contextLET
);
3304 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3305 right
= ffeexpr_convert (right
, NULL
, NULL
,
3306 FFEINFO_basictypeINTEGER
,
3308 FFETARGET_charactersizeNONE
,
3309 FFEEXPR_contextLET
);
3312 case FFEINFO_basictypeREAL
:
3313 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3314 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3315 FFEINFO_kindtypeREALDOUBLE
, 0,
3316 FFETARGET_charactersizeNONE
,
3317 FFEEXPR_contextLET
);
3318 if (ffeinfo_kindtype (ffebld_info (right
))
3319 == FFEINFO_kindtypeREAL1
)
3320 right
= ffeexpr_convert (right
, NULL
, NULL
,
3321 FFEINFO_basictypeREAL
,
3322 FFEINFO_kindtypeREALDOUBLE
, 0,
3323 FFETARGET_charactersizeNONE
,
3324 FFEEXPR_contextLET
);
3325 /* We used to call FFECOM_gfrtPOW_DD here,
3326 which passes arguments by reference. */
3327 code
= FFECOM_gfrtL_POW
;
3328 /* Pass arguments by value. */
3332 case FFEINFO_basictypeCOMPLEX
:
3333 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3334 left
= ffeexpr_convert (left
, NULL
, NULL
,
3335 FFEINFO_basictypeCOMPLEX
,
3336 FFEINFO_kindtypeREALDOUBLE
, 0,
3337 FFETARGET_charactersizeNONE
,
3338 FFEEXPR_contextLET
);
3339 if (ffeinfo_kindtype (ffebld_info (right
))
3340 == FFEINFO_kindtypeREAL1
)
3341 right
= ffeexpr_convert (right
, NULL
, NULL
,
3342 FFEINFO_basictypeCOMPLEX
,
3343 FFEINFO_kindtypeREALDOUBLE
, 0,
3344 FFETARGET_charactersizeNONE
,
3345 FFEEXPR_contextLET
);
3346 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3347 ref
= TRUE
; /* Pass arguments by reference. */
3351 assert ("bad pow_x*" == NULL
);
3352 code
= FFECOM_gfrtPOW_II
;
3355 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3356 ffecom_gfrt_kindtype (code
),
3357 (ffe_is_f2c_library ()
3358 && ffecom_gfrt_complex_
[code
]),
3359 tree_type
, left
, right
,
3360 dest_tree
, dest
, dest_used
,
3361 NULL_TREE
, FALSE
, ref
,
3362 ffebld_nonter_hook (expr
));
3368 case FFEINFO_basictypeLOGICAL
:
3369 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3370 return convert (tree_type
, item
);
3372 case FFEINFO_basictypeINTEGER
:
3373 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3374 ffecom_expr (ffebld_left (expr
)));
3377 assert ("NOT bad basictype" == NULL
);
3379 case FFEINFO_basictypeANY
:
3380 return error_mark_node
;
3384 case FFEBLD_opFUNCREF
:
3385 assert (ffeinfo_basictype (ffebld_info (expr
))
3386 != FFEINFO_basictypeCHARACTER
);
3388 case FFEBLD_opSUBRREF
:
3389 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3390 == FFEINFO_whereINTRINSIC
)
3391 { /* Invocation of an intrinsic. */
3392 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3396 s
= ffebld_symter (ffebld_left (expr
));
3397 dt
= ffesymbol_hook (s
).decl_tree
;
3398 if (dt
== NULL_TREE
)
3400 s
= ffecom_sym_transform_ (s
);
3401 dt
= ffesymbol_hook (s
).decl_tree
;
3403 if (dt
== error_mark_node
)
3406 if (ffesymbol_hook (s
).addr
)
3409 item
= ffecom_1_fn (dt
);
3411 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3412 args
= ffecom_list_expr (ffebld_right (expr
));
3414 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3416 if (args
== error_mark_node
)
3417 return error_mark_node
;
3419 item
= ffecom_call_ (item
, kt
,
3420 ffesymbol_is_f2c (s
)
3421 && (bt
== FFEINFO_basictypeCOMPLEX
)
3422 && (ffesymbol_where (s
)
3423 != FFEINFO_whereCONSTANT
),
3426 dest_tree
, dest
, dest_used
,
3427 error_mark_node
, FALSE
,
3428 ffebld_nonter_hook (expr
));
3429 TREE_SIDE_EFFECTS (item
) = 1;
3435 case FFEINFO_basictypeLOGICAL
:
3437 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3438 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3439 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3440 return convert (tree_type
, item
);
3442 case FFEINFO_basictypeINTEGER
:
3443 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3444 ffecom_expr (ffebld_left (expr
)),
3445 ffecom_expr (ffebld_right (expr
)));
3448 assert ("AND bad basictype" == NULL
);
3450 case FFEINFO_basictypeANY
:
3451 return error_mark_node
;
3458 case FFEINFO_basictypeLOGICAL
:
3460 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3461 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3462 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3463 return convert (tree_type
, item
);
3465 case FFEINFO_basictypeINTEGER
:
3466 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3467 ffecom_expr (ffebld_left (expr
)),
3468 ffecom_expr (ffebld_right (expr
)));
3471 assert ("OR bad basictype" == NULL
);
3473 case FFEINFO_basictypeANY
:
3474 return error_mark_node
;
3482 case FFEINFO_basictypeLOGICAL
:
3484 = ffecom_2 (NE_EXPR
, integer_type_node
,
3485 ffecom_expr (ffebld_left (expr
)),
3486 ffecom_expr (ffebld_right (expr
)));
3487 return convert (tree_type
, ffecom_truth_value (item
));
3489 case FFEINFO_basictypeINTEGER
:
3490 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3491 ffecom_expr (ffebld_left (expr
)),
3492 ffecom_expr (ffebld_right (expr
)));
3495 assert ("XOR/NEQV bad basictype" == NULL
);
3497 case FFEINFO_basictypeANY
:
3498 return error_mark_node
;
3505 case FFEINFO_basictypeLOGICAL
:
3507 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3508 ffecom_expr (ffebld_left (expr
)),
3509 ffecom_expr (ffebld_right (expr
)));
3510 return convert (tree_type
, ffecom_truth_value (item
));
3512 case FFEINFO_basictypeINTEGER
:
3514 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3515 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3516 ffecom_expr (ffebld_left (expr
)),
3517 ffecom_expr (ffebld_right (expr
))));
3520 assert ("EQV bad basictype" == NULL
);
3522 case FFEINFO_basictypeANY
:
3523 return error_mark_node
;
3527 case FFEBLD_opCONVERT
:
3528 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3529 return error_mark_node
;
3533 case FFEINFO_basictypeLOGICAL
:
3534 case FFEINFO_basictypeINTEGER
:
3535 case FFEINFO_basictypeREAL
:
3536 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3538 case FFEINFO_basictypeCOMPLEX
:
3539 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3541 case FFEINFO_basictypeINTEGER
:
3542 case FFEINFO_basictypeLOGICAL
:
3543 case FFEINFO_basictypeREAL
:
3544 item
= ffecom_expr (ffebld_left (expr
));
3545 if (item
== error_mark_node
)
3546 return error_mark_node
;
3547 /* convert() takes care of converting to the subtype first,
3548 at least in gcc-2.7.2. */
3549 item
= convert (tree_type
, item
);
3552 case FFEINFO_basictypeCOMPLEX
:
3553 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3556 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3558 case FFEINFO_basictypeANY
:
3559 return error_mark_node
;
3564 assert ("CONVERT bad basictype" == NULL
);
3566 case FFEINFO_basictypeANY
:
3567 return error_mark_node
;
3573 goto relational
; /* :::::::::::::::::::: */
3577 goto relational
; /* :::::::::::::::::::: */
3581 goto relational
; /* :::::::::::::::::::: */
3585 goto relational
; /* :::::::::::::::::::: */
3589 goto relational
; /* :::::::::::::::::::: */
3594 relational
: /* :::::::::::::::::::: */
3595 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3597 case FFEINFO_basictypeLOGICAL
:
3598 case FFEINFO_basictypeINTEGER
:
3599 case FFEINFO_basictypeREAL
:
3600 item
= ffecom_2 (code
, integer_type_node
,
3601 ffecom_expr (ffebld_left (expr
)),
3602 ffecom_expr (ffebld_right (expr
)));
3603 return convert (tree_type
, item
);
3605 case FFEINFO_basictypeCOMPLEX
:
3606 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3609 tree arg1
= ffecom_expr (ffebld_left (expr
));
3610 tree arg2
= ffecom_expr (ffebld_right (expr
));
3612 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3613 return error_mark_node
;
3615 arg1
= ffecom_save_tree (arg1
);
3616 arg2
= ffecom_save_tree (arg2
);
3618 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3620 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3621 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3625 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3626 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3630 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3631 ffecom_2 (EQ_EXPR
, integer_type_node
,
3632 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3633 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3634 ffecom_2 (EQ_EXPR
, integer_type_node
,
3635 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3636 ffecom_1 (IMAGPART_EXPR
, real_type
,
3638 if (code
== EQ_EXPR
)
3639 item
= ffecom_truth_value (item
);
3641 item
= ffecom_truth_value_invert (item
);
3642 return convert (tree_type
, item
);
3645 case FFEINFO_basictypeCHARACTER
:
3647 ffebld left
= ffebld_left (expr
);
3648 ffebld right
= ffebld_right (expr
);
3654 /* f2c run-time functions do the implicit blank-padding for us,
3655 so we don't usually have to implement blank-padding ourselves.
3656 (The exception is when we pass an argument to a separately
3657 compiled statement function -- if we know the arg is not the
3658 same length as the dummy, we must truncate or extend it. If
3659 we "inline" statement functions, that necessity goes away as
3662 Strip off the CONVERT operators that blank-pad. (Truncation by
3663 CONVERT shouldn't happen here, but it can happen in
3666 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3667 left
= ffebld_left (left
);
3668 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3669 right
= ffebld_left (right
);
3671 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3672 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3674 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3675 || right_tree
== error_mark_node
3676 || right_length
== error_mark_node
)
3677 return error_mark_node
;
3679 if ((ffebld_size_known (left
) == 1)
3680 && (ffebld_size_known (right
) == 1))
3683 = ffecom_1 (INDIRECT_REF
,
3684 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3687 = ffecom_1 (INDIRECT_REF
,
3688 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3692 = ffecom_2 (code
, integer_type_node
,
3693 ffecom_2 (ARRAY_REF
,
3694 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3697 ffecom_2 (ARRAY_REF
,
3698 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3704 item
= build_tree_list (NULL_TREE
, left_tree
);
3705 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3706 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3708 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3709 = build_tree_list (NULL_TREE
, right_length
);
3710 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3711 item
= ffecom_2 (code
, integer_type_node
,
3713 convert (TREE_TYPE (item
),
3714 integer_zero_node
));
3716 item
= convert (tree_type
, item
);
3722 assert ("relational bad basictype" == NULL
);
3724 case FFEINFO_basictypeANY
:
3725 return error_mark_node
;
3729 case FFEBLD_opPERCENT_LOC
:
3730 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3731 return convert (tree_type
, item
);
3733 case FFEBLD_opPERCENT_VAL
:
3734 item
= ffecom_arg_expr (ffebld_left (expr
), &list
);
3735 return convert (tree_type
, item
);
3739 case FFEBLD_opBOUNDS
:
3740 case FFEBLD_opREPEAT
:
3741 case FFEBLD_opLABTER
:
3742 case FFEBLD_opLABTOK
:
3743 case FFEBLD_opIMPDO
:
3744 case FFEBLD_opCONCATENATE
:
3745 case FFEBLD_opSUBSTR
:
3747 assert ("bad op" == NULL
);
3750 return error_mark_node
;
3754 assert ("didn't think anything got here anymore!!" == NULL
);
3756 switch (ffebld_arity (expr
))
3759 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3760 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3761 if (TREE_OPERAND (item
, 0) == error_mark_node
3762 || TREE_OPERAND (item
, 1) == error_mark_node
)
3763 return error_mark_node
;
3767 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3768 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3769 return error_mark_node
;
3780 /* Returns the tree that does the intrinsic invocation.
3782 Note: this function applies only to intrinsics returning
3783 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3787 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3788 ffebld dest
, bool *dest_used
)
3791 tree saved_expr1
; /* For those who need it. */
3792 tree saved_expr2
; /* For those who need it. */
3793 ffeinfoBasictype bt
;
3797 tree real_type
; /* REAL type corresponding to COMPLEX. */
3799 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3800 ffebld arg1
; /* For handy reference. */
3803 ffeintrinImp codegen_imp
;
3806 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3808 if (dest_used
!= NULL
)
3811 bt
= ffeinfo_basictype (ffebld_info (expr
));
3812 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3813 tree_type
= ffecom_tree_type
[bt
][kt
];
3817 arg1
= ffebld_head (list
);
3818 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3819 return error_mark_node
;
3820 if ((list
= ffebld_trail (list
)) != NULL
)
3822 arg2
= ffebld_head (list
);
3823 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3824 return error_mark_node
;
3825 if ((list
= ffebld_trail (list
)) != NULL
)
3827 arg3
= ffebld_head (list
);
3828 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3829 return error_mark_node
;
3838 arg1
= arg2
= arg3
= NULL
;
3840 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3841 args. This is used by the MAX/MIN expansions. */
3844 arg1_type
= ffecom_tree_type
3845 [ffeinfo_basictype (ffebld_info (arg1
))]
3846 [ffeinfo_kindtype (ffebld_info (arg1
))];
3848 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3851 /* There are several ways for each of the cases in the following switch
3852 statements to exit (from simplest to use to most complicated):
3854 break; (when expr_tree == NULL)
3856 A standard call is made to the specific intrinsic just as if it had been
3857 passed in as a dummy procedure and called as any old procedure. This
3858 method can produce slower code but in some cases it's the easiest way for
3859 now. However, if a (presumably faster) direct call is available,
3860 that is used, so this is the easiest way in many more cases now.
3862 gfrt = FFECOM_gfrtWHATEVER;
3865 gfrt contains the gfrt index of a library function to call, passing the
3866 argument(s) by value rather than by reference. Used when a more
3867 careful choice of library function is needed than that provided
3868 by the vanilla `break;'.
3872 The expr_tree has been completely set up and is ready to be returned
3873 as is. No further actions are taken. Use this when the tree is not
3874 in the simple form for one of the arity_n labels. */
3876 /* For info on how the switch statement cases were written, see the files
3877 enclosed in comments below the switch statement. */
3879 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3880 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3881 if (gfrt
== FFECOM_gfrt
)
3882 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3884 switch (codegen_imp
)
3886 case FFEINTRIN_impABS
:
3887 case FFEINTRIN_impCABS
:
3888 case FFEINTRIN_impCDABS
:
3889 case FFEINTRIN_impDABS
:
3890 case FFEINTRIN_impIABS
:
3891 if (ffeinfo_basictype (ffebld_info (arg1
))
3892 == FFEINFO_basictypeCOMPLEX
)
3894 if (kt
== FFEINFO_kindtypeREAL1
)
3895 gfrt
= FFECOM_gfrtCABS
;
3896 else if (kt
== FFEINFO_kindtypeREAL2
)
3897 gfrt
= FFECOM_gfrtCDABS
;
3900 return ffecom_1 (ABS_EXPR
, tree_type
,
3901 convert (tree_type
, ffecom_expr (arg1
)));
3903 case FFEINTRIN_impACOS
:
3904 case FFEINTRIN_impDACOS
:
3907 case FFEINTRIN_impAIMAG
:
3908 case FFEINTRIN_impDIMAG
:
3909 case FFEINTRIN_impIMAGPART
:
3910 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3911 arg1_type
= TREE_TYPE (arg1_type
);
3913 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3917 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3918 ffecom_expr (arg1
)));
3920 case FFEINTRIN_impAINT
:
3921 case FFEINTRIN_impDINT
:
3923 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3924 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3925 #else /* in the meantime, must use floor to avoid range problems with ints */
3926 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3927 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3930 ffecom_3 (COND_EXPR
, double_type_node
,
3932 (ffecom_2 (GE_EXPR
, integer_type_node
,
3935 ffecom_float_zero_
))),
3936 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3937 build_tree_list (NULL_TREE
,
3938 convert (double_type_node
,
3941 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3942 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3943 build_tree_list (NULL_TREE
,
3944 convert (double_type_node
,
3945 ffecom_1 (NEGATE_EXPR
,
3953 case FFEINTRIN_impANINT
:
3954 case FFEINTRIN_impDNINT
:
3955 #if 0 /* This way of doing it won't handle real
3956 numbers of large magnitudes. */
3957 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3958 expr_tree
= convert (tree_type
,
3959 convert (integer_type_node
,
3960 ffecom_3 (COND_EXPR
, tree_type
,
3965 ffecom_float_zero_
)),
3966 ffecom_2 (PLUS_EXPR
,
3969 ffecom_float_half_
),
3970 ffecom_2 (MINUS_EXPR
,
3973 ffecom_float_half_
))));
3975 #else /* So we instead call floor. */
3976 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3977 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3980 ffecom_3 (COND_EXPR
, double_type_node
,
3982 (ffecom_2 (GE_EXPR
, integer_type_node
,
3985 ffecom_float_zero_
))),
3986 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3987 build_tree_list (NULL_TREE
,
3988 convert (double_type_node
,
3989 ffecom_2 (PLUS_EXPR
,
3993 ffecom_float_half_
)))),
3995 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3996 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3997 build_tree_list (NULL_TREE
,
3998 convert (double_type_node
,
3999 ffecom_2 (MINUS_EXPR
,
4002 ffecom_float_half_
),
4009 case FFEINTRIN_impASIN
:
4010 case FFEINTRIN_impDASIN
:
4011 case FFEINTRIN_impATAN
:
4012 case FFEINTRIN_impDATAN
:
4013 case FFEINTRIN_impATAN2
:
4014 case FFEINTRIN_impDATAN2
:
4017 case FFEINTRIN_impCHAR
:
4018 case FFEINTRIN_impACHAR
:
4020 tempvar
= ffecom_make_tempvar (char_type_node
, 1, -1);
4022 tempvar
= ffebld_nonter_hook (expr
);
4026 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4028 expr_tree
= ffecom_modify (tmv
,
4029 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4031 convert (tmv
, ffecom_expr (arg1
)));
4033 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4036 expr_tree
= ffecom_1 (ADDR_EXPR
,
4037 build_pointer_type (TREE_TYPE (expr_tree
)),
4041 case FFEINTRIN_impCMPLX
:
4042 case FFEINTRIN_impDCMPLX
:
4045 convert (tree_type
, ffecom_expr (arg1
));
4047 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4049 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4050 convert (real_type
, ffecom_expr (arg1
)),
4052 ffecom_expr (arg2
)));
4054 case FFEINTRIN_impCOMPLEX
:
4056 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4058 ffecom_expr (arg2
));
4060 case FFEINTRIN_impCONJG
:
4061 case FFEINTRIN_impDCONJG
:
4065 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4066 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4068 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4069 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4070 ffecom_1 (NEGATE_EXPR
, real_type
,
4071 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4074 case FFEINTRIN_impCOS
:
4075 case FFEINTRIN_impCCOS
:
4076 case FFEINTRIN_impCDCOS
:
4077 case FFEINTRIN_impDCOS
:
4078 if (bt
== FFEINFO_basictypeCOMPLEX
)
4080 if (kt
== FFEINFO_kindtypeREAL1
)
4081 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4082 else if (kt
== FFEINFO_kindtypeREAL2
)
4083 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4087 case FFEINTRIN_impCOSH
:
4088 case FFEINTRIN_impDCOSH
:
4091 case FFEINTRIN_impDBLE
:
4092 case FFEINTRIN_impDFLOAT
:
4093 case FFEINTRIN_impDREAL
:
4094 case FFEINTRIN_impFLOAT
:
4095 case FFEINTRIN_impIDINT
:
4096 case FFEINTRIN_impIFIX
:
4097 case FFEINTRIN_impINT2
:
4098 case FFEINTRIN_impINT8
:
4099 case FFEINTRIN_impINT
:
4100 case FFEINTRIN_impLONG
:
4101 case FFEINTRIN_impREAL
:
4102 case FFEINTRIN_impSHORT
:
4103 case FFEINTRIN_impSNGL
:
4104 return convert (tree_type
, ffecom_expr (arg1
));
4106 case FFEINTRIN_impDIM
:
4107 case FFEINTRIN_impDDIM
:
4108 case FFEINTRIN_impIDIM
:
4109 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4110 ffecom_expr (arg1
)));
4111 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4112 ffecom_expr (arg2
)));
4114 ffecom_3 (COND_EXPR
, tree_type
,
4116 (ffecom_2 (GT_EXPR
, integer_type_node
,
4119 ffecom_2 (MINUS_EXPR
, tree_type
,
4122 convert (tree_type
, ffecom_float_zero_
));
4124 case FFEINTRIN_impDPROD
:
4126 ffecom_2 (MULT_EXPR
, tree_type
,
4127 convert (tree_type
, ffecom_expr (arg1
)),
4128 convert (tree_type
, ffecom_expr (arg2
)));
4130 case FFEINTRIN_impEXP
:
4131 case FFEINTRIN_impCDEXP
:
4132 case FFEINTRIN_impCEXP
:
4133 case FFEINTRIN_impDEXP
:
4134 if (bt
== FFEINFO_basictypeCOMPLEX
)
4136 if (kt
== FFEINFO_kindtypeREAL1
)
4137 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4138 else if (kt
== FFEINFO_kindtypeREAL2
)
4139 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4143 case FFEINTRIN_impICHAR
:
4144 case FFEINTRIN_impIACHAR
:
4145 #if 0 /* The simple approach. */
4146 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4148 = ffecom_1 (INDIRECT_REF
,
4149 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4152 = ffecom_2 (ARRAY_REF
,
4153 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4156 return convert (tree_type
, expr_tree
);
4157 #else /* The more interesting (and more optimal) approach. */
4158 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4159 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4162 convert (tree_type
, integer_zero_node
));
4166 case FFEINTRIN_impINDEX
:
4169 case FFEINTRIN_impLEN
:
4171 break; /* The simple approach. */
4173 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4176 case FFEINTRIN_impLGE
:
4177 case FFEINTRIN_impLGT
:
4178 case FFEINTRIN_impLLE
:
4179 case FFEINTRIN_impLLT
:
4182 case FFEINTRIN_impLOG
:
4183 case FFEINTRIN_impALOG
:
4184 case FFEINTRIN_impCDLOG
:
4185 case FFEINTRIN_impCLOG
:
4186 case FFEINTRIN_impDLOG
:
4187 if (bt
== FFEINFO_basictypeCOMPLEX
)
4189 if (kt
== FFEINFO_kindtypeREAL1
)
4190 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4191 else if (kt
== FFEINFO_kindtypeREAL2
)
4192 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4196 case FFEINTRIN_impLOG10
:
4197 case FFEINTRIN_impALOG10
:
4198 case FFEINTRIN_impDLOG10
:
4199 if (gfrt
!= FFECOM_gfrt
)
4200 break; /* Already picked one, stick with it. */
4202 if (kt
== FFEINFO_kindtypeREAL1
)
4203 /* We used to call FFECOM_gfrtALOG10 here. */
4204 gfrt
= FFECOM_gfrtL_LOG10
;
4205 else if (kt
== FFEINFO_kindtypeREAL2
)
4206 /* We used to call FFECOM_gfrtDLOG10 here. */
4207 gfrt
= FFECOM_gfrtL_LOG10
;
4210 case FFEINTRIN_impMAX
:
4211 case FFEINTRIN_impAMAX0
:
4212 case FFEINTRIN_impAMAX1
:
4213 case FFEINTRIN_impDMAX1
:
4214 case FFEINTRIN_impMAX0
:
4215 case FFEINTRIN_impMAX1
:
4216 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4217 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4219 arg1_type
= tree_type
;
4220 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4221 convert (arg1_type
, ffecom_expr (arg1
)),
4222 convert (arg1_type
, ffecom_expr (arg2
)));
4223 for (; list
!= NULL
; list
= ffebld_trail (list
))
4225 if ((ffebld_head (list
) == NULL
)
4226 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4228 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4231 ffecom_expr (ffebld_head (list
))));
4233 return convert (tree_type
, expr_tree
);
4235 case FFEINTRIN_impMIN
:
4236 case FFEINTRIN_impAMIN0
:
4237 case FFEINTRIN_impAMIN1
:
4238 case FFEINTRIN_impDMIN1
:
4239 case FFEINTRIN_impMIN0
:
4240 case FFEINTRIN_impMIN1
:
4241 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4242 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4244 arg1_type
= tree_type
;
4245 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4246 convert (arg1_type
, ffecom_expr (arg1
)),
4247 convert (arg1_type
, ffecom_expr (arg2
)));
4248 for (; list
!= NULL
; list
= ffebld_trail (list
))
4250 if ((ffebld_head (list
) == NULL
)
4251 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4253 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4256 ffecom_expr (ffebld_head (list
))));
4258 return convert (tree_type
, expr_tree
);
4260 case FFEINTRIN_impMOD
:
4261 case FFEINTRIN_impAMOD
:
4262 case FFEINTRIN_impDMOD
:
4263 if (bt
!= FFEINFO_basictypeREAL
)
4264 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4265 convert (tree_type
, ffecom_expr (arg1
)),
4266 convert (tree_type
, ffecom_expr (arg2
)));
4268 if (kt
== FFEINFO_kindtypeREAL1
)
4269 /* We used to call FFECOM_gfrtAMOD here. */
4270 gfrt
= FFECOM_gfrtL_FMOD
;
4271 else if (kt
== FFEINFO_kindtypeREAL2
)
4272 /* We used to call FFECOM_gfrtDMOD here. */
4273 gfrt
= FFECOM_gfrtL_FMOD
;
4276 case FFEINTRIN_impNINT
:
4277 case FFEINTRIN_impIDNINT
:
4279 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4280 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4282 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4283 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4285 convert (ffecom_integer_type_node
,
4286 ffecom_3 (COND_EXPR
, arg1_type
,
4288 (ffecom_2 (GE_EXPR
, integer_type_node
,
4291 ffecom_float_zero_
))),
4292 ffecom_2 (PLUS_EXPR
, arg1_type
,
4295 ffecom_float_half_
)),
4296 ffecom_2 (MINUS_EXPR
, arg1_type
,
4299 ffecom_float_half_
))));
4302 case FFEINTRIN_impSIGN
:
4303 case FFEINTRIN_impDSIGN
:
4304 case FFEINTRIN_impISIGN
:
4306 tree arg2_tree
= ffecom_expr (arg2
);
4310 (ffecom_1 (ABS_EXPR
, tree_type
,
4312 ffecom_expr (arg1
))));
4314 = ffecom_3 (COND_EXPR
, tree_type
,
4316 (ffecom_2 (GE_EXPR
, integer_type_node
,
4318 convert (TREE_TYPE (arg2_tree
),
4319 integer_zero_node
))),
4321 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4322 /* Make sure SAVE_EXPRs get referenced early enough. */
4324 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4325 convert (void_type_node
, saved_expr1
),
4330 case FFEINTRIN_impSIN
:
4331 case FFEINTRIN_impCDSIN
:
4332 case FFEINTRIN_impCSIN
:
4333 case FFEINTRIN_impDSIN
:
4334 if (bt
== FFEINFO_basictypeCOMPLEX
)
4336 if (kt
== FFEINFO_kindtypeREAL1
)
4337 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4338 else if (kt
== FFEINFO_kindtypeREAL2
)
4339 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4343 case FFEINTRIN_impSINH
:
4344 case FFEINTRIN_impDSINH
:
4347 case FFEINTRIN_impSQRT
:
4348 case FFEINTRIN_impCDSQRT
:
4349 case FFEINTRIN_impCSQRT
:
4350 case FFEINTRIN_impDSQRT
:
4351 if (bt
== FFEINFO_basictypeCOMPLEX
)
4353 if (kt
== FFEINFO_kindtypeREAL1
)
4354 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4355 else if (kt
== FFEINFO_kindtypeREAL2
)
4356 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4360 case FFEINTRIN_impTAN
:
4361 case FFEINTRIN_impDTAN
:
4362 case FFEINTRIN_impTANH
:
4363 case FFEINTRIN_impDTANH
:
4366 case FFEINTRIN_impREALPART
:
4367 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4368 arg1_type
= TREE_TYPE (arg1_type
);
4370 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4374 ffecom_1 (REALPART_EXPR
, arg1_type
,
4375 ffecom_expr (arg1
)));
4377 case FFEINTRIN_impIAND
:
4378 case FFEINTRIN_impAND
:
4379 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4381 ffecom_expr (arg1
)),
4383 ffecom_expr (arg2
)));
4385 case FFEINTRIN_impIOR
:
4386 case FFEINTRIN_impOR
:
4387 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4389 ffecom_expr (arg1
)),
4391 ffecom_expr (arg2
)));
4393 case FFEINTRIN_impIEOR
:
4394 case FFEINTRIN_impXOR
:
4395 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4397 ffecom_expr (arg1
)),
4399 ffecom_expr (arg2
)));
4401 case FFEINTRIN_impLSHIFT
:
4402 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4404 convert (integer_type_node
,
4405 ffecom_expr (arg2
)));
4407 case FFEINTRIN_impRSHIFT
:
4408 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4410 convert (integer_type_node
,
4411 ffecom_expr (arg2
)));
4413 case FFEINTRIN_impNOT
:
4414 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4416 case FFEINTRIN_impBIT_SIZE
:
4417 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4419 case FFEINTRIN_impBTEST
:
4421 ffetargetLogical1 target_true
;
4422 ffetargetLogical1 target_false
;
4426 ffetarget_logical1 (&target_true
, TRUE
);
4427 ffetarget_logical1 (&target_false
, FALSE
);
4428 if (target_true
== 1)
4429 true_tree
= convert (tree_type
, integer_one_node
);
4431 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4432 if (target_false
== 0)
4433 false_tree
= convert (tree_type
, integer_zero_node
);
4435 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4438 ffecom_3 (COND_EXPR
, tree_type
,
4440 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4441 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4443 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4446 convert (integer_type_node
,
4447 ffecom_expr (arg2
)))),
4449 integer_zero_node
))),
4454 case FFEINTRIN_impIBCLR
:
4456 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4458 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4459 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4462 convert (integer_type_node
,
4463 ffecom_expr (arg2
)))));
4465 case FFEINTRIN_impIBITS
:
4467 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4468 ffecom_expr (arg3
)));
4470 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4473 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4474 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4476 convert (integer_type_node
,
4477 ffecom_expr (arg2
))),
4479 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4480 ffecom_1 (BIT_NOT_EXPR
,
4483 integer_zero_node
)),
4484 ffecom_2 (MINUS_EXPR
,
4486 TYPE_SIZE (uns_type
),
4488 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4490 = ffecom_3 (COND_EXPR
, tree_type
,
4492 (ffecom_2 (NE_EXPR
, integer_type_node
,
4494 integer_zero_node
)),
4496 convert (tree_type
, integer_zero_node
));
4500 case FFEINTRIN_impIBSET
:
4502 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4504 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4505 convert (tree_type
, integer_one_node
),
4506 convert (integer_type_node
,
4507 ffecom_expr (arg2
))));
4509 case FFEINTRIN_impISHFT
:
4511 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4512 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4513 ffecom_expr (arg2
)));
4515 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4518 = ffecom_3 (COND_EXPR
, tree_type
,
4520 (ffecom_2 (GE_EXPR
, integer_type_node
,
4522 integer_zero_node
)),
4523 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4527 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4528 convert (uns_type
, arg1_tree
),
4529 ffecom_1 (NEGATE_EXPR
,
4532 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4534 = ffecom_3 (COND_EXPR
, tree_type
,
4536 (ffecom_2 (NE_EXPR
, integer_type_node
,
4540 TYPE_SIZE (uns_type
))),
4542 convert (tree_type
, integer_zero_node
));
4543 /* Make sure SAVE_EXPRs get referenced early enough. */
4545 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4546 convert (void_type_node
, arg1_tree
),
4547 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4548 convert (void_type_node
, arg2_tree
),
4553 case FFEINTRIN_impISHFTC
:
4555 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4556 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4557 ffecom_expr (arg2
)));
4558 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4559 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4565 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4568 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4569 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4570 convert (tree_type
, integer_zero_node
)),
4572 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4574 = ffecom_3 (COND_EXPR
, tree_type
,
4576 (ffecom_2 (NE_EXPR
, integer_type_node
,
4578 TYPE_SIZE (uns_type
))),
4580 convert (tree_type
, integer_zero_node
));
4581 mask_arg1
= ffecom_save_tree (mask_arg1
);
4583 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4585 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4587 masked_arg1
= ffecom_save_tree (masked_arg1
);
4589 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4591 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4592 convert (uns_type
, masked_arg1
),
4593 ffecom_1 (NEGATE_EXPR
,
4596 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4598 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4602 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4603 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4607 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4608 convert (uns_type
, masked_arg1
),
4609 ffecom_2 (MINUS_EXPR
,
4614 = ffecom_3 (COND_EXPR
, tree_type
,
4616 (ffecom_2 (LT_EXPR
, integer_type_node
,
4618 integer_zero_node
)),
4622 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4623 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4626 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4627 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4631 = ffecom_3 (COND_EXPR
, tree_type
,
4633 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4634 ffecom_2 (EQ_EXPR
, integer_type_node
,
4639 ffecom_2 (EQ_EXPR
, integer_type_node
,
4641 integer_zero_node
))),
4644 /* Make sure SAVE_EXPRs get referenced early enough. */
4646 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4647 convert (void_type_node
, arg1_tree
),
4648 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4649 convert (void_type_node
, arg2_tree
),
4650 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4651 convert (void_type_node
,
4653 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4654 convert (void_type_node
,
4658 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4659 convert (void_type_node
,
4665 case FFEINTRIN_impLOC
:
4667 tree arg1_tree
= ffecom_expr (arg1
);
4670 = convert (tree_type
,
4671 ffecom_1 (ADDR_EXPR
,
4672 build_pointer_type (TREE_TYPE (arg1_tree
)),
4677 case FFEINTRIN_impMVBITS
:
4682 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4685 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4689 tree arg5_plus_arg3
;
4691 arg2_tree
= convert (integer_type_node
,
4692 ffecom_expr (arg2
));
4693 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4694 ffecom_expr (arg3
)));
4695 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4696 arg4_type
= TREE_TYPE (arg4_tree
);
4698 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4699 ffecom_expr (arg1
)));
4701 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4702 ffecom_expr (arg5
)));
4705 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4706 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4707 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4710 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4711 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4712 ffecom_1 (BIT_NOT_EXPR
,
4716 integer_zero_node
)),
4720 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4724 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4725 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4727 integer_zero_node
)),
4729 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4731 = ffecom_3 (COND_EXPR
, arg4_type
,
4733 (ffecom_2 (NE_EXPR
, integer_type_node
,
4735 convert (TREE_TYPE (arg5_plus_arg3
),
4736 TYPE_SIZE (arg4_type
)))),
4738 convert (arg4_type
, integer_zero_node
));
4740 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4742 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4744 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4745 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4746 ffecom_1 (BIT_NOT_EXPR
,
4750 integer_zero_node
)),
4753 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4756 /* Fix up (twice), because LSHIFT_EXPR above
4757 can't shift over TYPE_SIZE. */
4759 = ffecom_3 (COND_EXPR
, arg4_type
,
4761 (ffecom_2 (NE_EXPR
, integer_type_node
,
4763 convert (TREE_TYPE (arg3_tree
),
4764 integer_zero_node
))),
4768 = ffecom_3 (COND_EXPR
, arg4_type
,
4770 (ffecom_2 (NE_EXPR
, integer_type_node
,
4772 convert (TREE_TYPE (arg3_tree
),
4773 TYPE_SIZE (arg4_type
)))),
4777 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4780 /* Make sure SAVE_EXPRs get referenced early enough. */
4782 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4784 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4786 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4788 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4792 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4799 case FFEINTRIN_impDERF
:
4800 case FFEINTRIN_impERF
:
4801 case FFEINTRIN_impDERFC
:
4802 case FFEINTRIN_impERFC
:
4805 case FFEINTRIN_impIARGC
:
4806 /* extern int xargc; i__1 = xargc - 1; */
4807 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4809 convert (TREE_TYPE (ffecom_tree_xargc_
),
4813 case FFEINTRIN_impSIGNAL_func
:
4814 case FFEINTRIN_impSIGNAL_subr
:
4820 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4821 ffecom_expr (arg1
));
4822 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4823 build_pointer_type (TREE_TYPE (arg1_tree
)),
4826 /* Pass procedure as a pointer to it, anything else by value. */
4827 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4828 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4830 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4831 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4835 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4837 arg3_tree
= NULL_TREE
;
4839 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4840 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4841 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4844 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4845 ffecom_gfrt_kindtype (gfrt
),
4847 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4851 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4852 ffebld_nonter_hook (expr
));
4854 if (arg3_tree
!= NULL_TREE
)
4856 = ffecom_modify (NULL_TREE
, arg3_tree
,
4857 convert (TREE_TYPE (arg3_tree
),
4862 case FFEINTRIN_impALARM
:
4868 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4869 ffecom_expr (arg1
));
4870 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4871 build_pointer_type (TREE_TYPE (arg1_tree
)),
4874 /* Pass procedure as a pointer to it, anything else by value. */
4875 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4876 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4878 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4879 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4883 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4885 arg3_tree
= NULL_TREE
;
4887 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4888 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4889 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4892 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4893 ffecom_gfrt_kindtype (gfrt
),
4897 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4898 ffebld_nonter_hook (expr
));
4900 if (arg3_tree
!= NULL_TREE
)
4902 = ffecom_modify (NULL_TREE
, arg3_tree
,
4903 convert (TREE_TYPE (arg3_tree
),
4908 case FFEINTRIN_impCHDIR_subr
:
4909 case FFEINTRIN_impFDATE_subr
:
4910 case FFEINTRIN_impFGET_subr
:
4911 case FFEINTRIN_impFPUT_subr
:
4912 case FFEINTRIN_impGETCWD_subr
:
4913 case FFEINTRIN_impHOSTNM_subr
:
4914 case FFEINTRIN_impSYSTEM_subr
:
4915 case FFEINTRIN_impUNLINK_subr
:
4917 tree arg1_len
= integer_zero_node
;
4921 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4924 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4926 arg2_tree
= NULL_TREE
;
4928 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4929 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4930 TREE_CHAIN (arg1_tree
) = arg1_len
;
4933 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4934 ffecom_gfrt_kindtype (gfrt
),
4938 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4939 ffebld_nonter_hook (expr
));
4941 if (arg2_tree
!= NULL_TREE
)
4943 = ffecom_modify (NULL_TREE
, arg2_tree
,
4944 convert (TREE_TYPE (arg2_tree
),
4949 case FFEINTRIN_impEXIT
:
4953 expr_tree
= build_tree_list (NULL_TREE
,
4954 ffecom_1 (ADDR_EXPR
,
4956 (ffecom_integer_type_node
),
4957 integer_zero_node
));
4960 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4961 ffecom_gfrt_kindtype (gfrt
),
4965 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4966 ffebld_nonter_hook (expr
));
4968 case FFEINTRIN_impFLUSH
:
4970 gfrt
= FFECOM_gfrtFLUSH
;
4972 gfrt
= FFECOM_gfrtFLUSH1
;
4975 case FFEINTRIN_impCHMOD_subr
:
4976 case FFEINTRIN_impLINK_subr
:
4977 case FFEINTRIN_impRENAME_subr
:
4978 case FFEINTRIN_impSYMLNK_subr
:
4980 tree arg1_len
= integer_zero_node
;
4982 tree arg2_len
= integer_zero_node
;
4986 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4987 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4989 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4991 arg3_tree
= NULL_TREE
;
4993 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4994 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4995 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4996 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4997 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4998 TREE_CHAIN (arg2_tree
) = arg1_len
;
4999 TREE_CHAIN (arg1_len
) = arg2_len
;
5000 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5001 ffecom_gfrt_kindtype (gfrt
),
5005 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5006 ffebld_nonter_hook (expr
));
5007 if (arg3_tree
!= NULL_TREE
)
5008 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5009 convert (TREE_TYPE (arg3_tree
),
5014 case FFEINTRIN_impLSTAT_subr
:
5015 case FFEINTRIN_impSTAT_subr
:
5017 tree arg1_len
= integer_zero_node
;
5022 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5024 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5027 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5029 arg3_tree
= NULL_TREE
;
5031 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5032 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5033 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5034 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5035 TREE_CHAIN (arg2_tree
) = arg1_len
;
5036 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5037 ffecom_gfrt_kindtype (gfrt
),
5041 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5042 ffebld_nonter_hook (expr
));
5043 if (arg3_tree
!= NULL_TREE
)
5044 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5045 convert (TREE_TYPE (arg3_tree
),
5050 case FFEINTRIN_impFGETC_subr
:
5051 case FFEINTRIN_impFPUTC_subr
:
5055 tree arg2_len
= integer_zero_node
;
5058 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5059 ffecom_expr (arg1
));
5060 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5061 build_pointer_type (TREE_TYPE (arg1_tree
)),
5064 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5066 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5068 arg3_tree
= NULL_TREE
;
5070 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5071 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5072 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5073 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5074 TREE_CHAIN (arg2_tree
) = arg2_len
;
5076 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5077 ffecom_gfrt_kindtype (gfrt
),
5081 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5082 ffebld_nonter_hook (expr
));
5083 if (arg3_tree
!= NULL_TREE
)
5084 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5085 convert (TREE_TYPE (arg3_tree
),
5090 case FFEINTRIN_impFSTAT_subr
:
5096 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5097 ffecom_expr (arg1
));
5098 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5099 build_pointer_type (TREE_TYPE (arg1_tree
)),
5102 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5103 ffecom_ptr_to_expr (arg2
));
5106 arg3_tree
= NULL_TREE
;
5108 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5110 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5111 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5112 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5113 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5114 ffecom_gfrt_kindtype (gfrt
),
5118 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5119 ffebld_nonter_hook (expr
));
5120 if (arg3_tree
!= NULL_TREE
) {
5121 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5122 convert (TREE_TYPE (arg3_tree
),
5128 case FFEINTRIN_impKILL_subr
:
5134 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5135 ffecom_expr (arg1
));
5136 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5137 build_pointer_type (TREE_TYPE (arg1_tree
)),
5140 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5141 ffecom_expr (arg2
));
5142 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5143 build_pointer_type (TREE_TYPE (arg2_tree
)),
5147 arg3_tree
= NULL_TREE
;
5149 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5151 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5152 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5153 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5154 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5155 ffecom_gfrt_kindtype (gfrt
),
5159 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5160 ffebld_nonter_hook (expr
));
5161 if (arg3_tree
!= NULL_TREE
) {
5162 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5163 convert (TREE_TYPE (arg3_tree
),
5169 case FFEINTRIN_impCTIME_subr
:
5170 case FFEINTRIN_impTTYNAM_subr
:
5172 tree arg1_len
= integer_zero_node
;
5176 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5178 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5179 ffecom_f2c_longint_type_node
:
5180 ffecom_f2c_integer_type_node
),
5181 ffecom_expr (arg1
));
5182 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5183 build_pointer_type (TREE_TYPE (arg2_tree
)),
5186 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5187 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5188 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5189 TREE_CHAIN (arg1_len
) = arg2_tree
;
5190 TREE_CHAIN (arg1_tree
) = arg1_len
;
5193 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5194 ffecom_gfrt_kindtype (gfrt
),
5198 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5199 ffebld_nonter_hook (expr
));
5200 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5204 case FFEINTRIN_impIRAND
:
5205 case FFEINTRIN_impRAND
:
5206 /* Arg defaults to 0 (normal random case) */
5211 arg1_tree
= ffecom_integer_zero_node
;
5213 arg1_tree
= ffecom_expr (arg1
);
5214 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5216 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5217 build_pointer_type (TREE_TYPE (arg1_tree
)),
5219 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5221 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5222 ffecom_gfrt_kindtype (gfrt
),
5224 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5225 ffecom_f2c_integer_type_node
:
5226 ffecom_f2c_real_type_node
),
5228 dest_tree
, dest
, dest_used
,
5230 ffebld_nonter_hook (expr
));
5234 case FFEINTRIN_impFTELL_subr
:
5235 case FFEINTRIN_impUMASK_subr
:
5240 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5241 ffecom_expr (arg1
));
5242 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5243 build_pointer_type (TREE_TYPE (arg1_tree
)),
5247 arg2_tree
= NULL_TREE
;
5249 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5251 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5252 ffecom_gfrt_kindtype (gfrt
),
5255 build_tree_list (NULL_TREE
, arg1_tree
),
5256 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5258 ffebld_nonter_hook (expr
));
5259 if (arg2_tree
!= NULL_TREE
) {
5260 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5261 convert (TREE_TYPE (arg2_tree
),
5267 case FFEINTRIN_impCPU_TIME
:
5268 case FFEINTRIN_impSECOND_subr
:
5272 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5275 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5276 ffecom_gfrt_kindtype (gfrt
),
5280 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5281 ffebld_nonter_hook (expr
));
5284 = ffecom_modify (NULL_TREE
, arg1_tree
,
5285 convert (TREE_TYPE (arg1_tree
),
5290 case FFEINTRIN_impDTIME_subr
:
5291 case FFEINTRIN_impETIME_subr
:
5296 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5298 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5300 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5301 ffecom_gfrt_kindtype (gfrt
),
5304 build_tree_list (NULL_TREE
, arg1_tree
),
5305 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5307 ffebld_nonter_hook (expr
));
5308 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5309 convert (TREE_TYPE (result_tree
),
5314 /* Straightforward calls of libf2c routines: */
5315 case FFEINTRIN_impABORT
:
5316 case FFEINTRIN_impACCESS
:
5317 case FFEINTRIN_impBESJ0
:
5318 case FFEINTRIN_impBESJ1
:
5319 case FFEINTRIN_impBESJN
:
5320 case FFEINTRIN_impBESY0
:
5321 case FFEINTRIN_impBESY1
:
5322 case FFEINTRIN_impBESYN
:
5323 case FFEINTRIN_impCHDIR_func
:
5324 case FFEINTRIN_impCHMOD_func
:
5325 case FFEINTRIN_impDATE
:
5326 case FFEINTRIN_impDATE_AND_TIME
:
5327 case FFEINTRIN_impDBESJ0
:
5328 case FFEINTRIN_impDBESJ1
:
5329 case FFEINTRIN_impDBESJN
:
5330 case FFEINTRIN_impDBESY0
:
5331 case FFEINTRIN_impDBESY1
:
5332 case FFEINTRIN_impDBESYN
:
5333 case FFEINTRIN_impDTIME_func
:
5334 case FFEINTRIN_impETIME_func
:
5335 case FFEINTRIN_impFGETC_func
:
5336 case FFEINTRIN_impFGET_func
:
5337 case FFEINTRIN_impFNUM
:
5338 case FFEINTRIN_impFPUTC_func
:
5339 case FFEINTRIN_impFPUT_func
:
5340 case FFEINTRIN_impFSEEK
:
5341 case FFEINTRIN_impFSTAT_func
:
5342 case FFEINTRIN_impFTELL_func
:
5343 case FFEINTRIN_impGERROR
:
5344 case FFEINTRIN_impGETARG
:
5345 case FFEINTRIN_impGETCWD_func
:
5346 case FFEINTRIN_impGETENV
:
5347 case FFEINTRIN_impGETGID
:
5348 case FFEINTRIN_impGETLOG
:
5349 case FFEINTRIN_impGETPID
:
5350 case FFEINTRIN_impGETUID
:
5351 case FFEINTRIN_impGMTIME
:
5352 case FFEINTRIN_impHOSTNM_func
:
5353 case FFEINTRIN_impIDATE_unix
:
5354 case FFEINTRIN_impIDATE_vxt
:
5355 case FFEINTRIN_impIERRNO
:
5356 case FFEINTRIN_impISATTY
:
5357 case FFEINTRIN_impITIME
:
5358 case FFEINTRIN_impKILL_func
:
5359 case FFEINTRIN_impLINK_func
:
5360 case FFEINTRIN_impLNBLNK
:
5361 case FFEINTRIN_impLSTAT_func
:
5362 case FFEINTRIN_impLTIME
:
5363 case FFEINTRIN_impMCLOCK8
:
5364 case FFEINTRIN_impMCLOCK
:
5365 case FFEINTRIN_impPERROR
:
5366 case FFEINTRIN_impRENAME_func
:
5367 case FFEINTRIN_impSECNDS
:
5368 case FFEINTRIN_impSECOND_func
:
5369 case FFEINTRIN_impSLEEP
:
5370 case FFEINTRIN_impSRAND
:
5371 case FFEINTRIN_impSTAT_func
:
5372 case FFEINTRIN_impSYMLNK_func
:
5373 case FFEINTRIN_impSYSTEM_CLOCK
:
5374 case FFEINTRIN_impSYSTEM_func
:
5375 case FFEINTRIN_impTIME8
:
5376 case FFEINTRIN_impTIME_unix
:
5377 case FFEINTRIN_impTIME_vxt
:
5378 case FFEINTRIN_impUMASK_func
:
5379 case FFEINTRIN_impUNLINK_func
:
5382 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5383 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5384 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5385 case FFEINTRIN_impNONE
:
5386 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5387 fprintf (stderr
, "No %s implementation.\n",
5388 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5389 assert ("unimplemented intrinsic" == NULL
);
5390 return error_mark_node
;
5393 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5395 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5396 ffebld_right (expr
));
5398 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5399 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5401 expr_tree
, dest_tree
, dest
, dest_used
,
5403 ffebld_nonter_hook (expr
));
5405 /* See bottom of this file for f2c transforms used to determine
5406 many of the above implementations. The info seems to confuse
5407 Emacs's C mode indentation, which is why it's been moved to
5408 the bottom of this source file. */
5411 /* For power (exponentiation) where right-hand operand is type INTEGER,
5412 generate in-line code to do it the fast way (which, if the operand
5413 is a constant, might just mean a series of multiplies). */
5416 ffecom_expr_power_integer_ (ffebld expr
)
5418 tree l
= ffecom_expr (ffebld_left (expr
));
5419 tree r
= ffecom_expr (ffebld_right (expr
));
5420 tree ltype
= TREE_TYPE (l
);
5421 tree rtype
= TREE_TYPE (r
);
5422 tree result
= NULL_TREE
;
5424 if (l
== error_mark_node
5425 || r
== error_mark_node
)
5426 return error_mark_node
;
5428 if (TREE_CODE (r
) == INTEGER_CST
)
5430 int sgn
= tree_int_cst_sgn (r
);
5433 return convert (ltype
, integer_one_node
);
5435 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5438 /* Reciprocal of integer is either 0, -1, or 1, so after
5439 calculating that (which we leave to the back end to do
5440 or not do optimally), don't bother with any multiplying. */
5442 result
= ffecom_tree_divide_ (ltype
,
5443 convert (ltype
, integer_one_node
),
5445 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5446 r
= ffecom_1 (NEGATE_EXPR
,
5449 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5450 result
= ffecom_1 (ABS_EXPR
, rtype
,
5454 /* Generate appropriate series of multiplies, preceded
5455 by divide if the exponent is negative. */
5461 l
= ffecom_tree_divide_ (ltype
,
5462 convert (ltype
, integer_one_node
),
5464 NULL_TREE
, NULL
, NULL
,
5465 ffebld_nonter_hook (expr
));
5466 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5467 assert (TREE_CODE (r
) == INTEGER_CST
);
5469 if (tree_int_cst_sgn (r
) < 0)
5470 { /* The "most negative" number. */
5471 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5472 ffecom_2 (RSHIFT_EXPR
, rtype
,
5476 l
= ffecom_2 (MULT_EXPR
, ltype
,
5484 if (TREE_INT_CST_LOW (r
) & 1)
5486 if (result
== NULL_TREE
)
5489 result
= ffecom_2 (MULT_EXPR
, ltype
,
5494 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5497 if (integer_zerop (r
))
5499 assert (TREE_CODE (r
) == INTEGER_CST
);
5502 l
= ffecom_2 (MULT_EXPR
, ltype
,
5509 /* Though rhs isn't a constant, in-line code cannot be expanded
5510 while transforming dummies
5511 because the back end cannot be easily convinced to generate
5512 stores (MODIFY_EXPR), handle temporaries, and so on before
5513 all the appropriate rtx's have been generated for things like
5514 dummy args referenced in rhs -- which doesn't happen until
5515 store_parm_decls() is called (expand_function_start, I believe,
5516 does the actual rtx-stuffing of PARM_DECLs).
5518 So, in this case, let the caller generate the call to the
5519 run-time-library function to evaluate the power for us. */
5521 if (ffecom_transform_only_dummies_
)
5524 /* Right-hand operand not a constant, expand in-line code to figure
5525 out how to do the multiplies, &c.
5527 The returned expression is expressed this way in GNU C, where l and
5530 ({ typeof (r) rtmp = r;
5531 typeof (l) ltmp = l;
5538 if ((basetypeof (l) == basetypeof (int))
5541 result = ((typeof (l)) 1) / ltmp;
5542 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5548 if ((basetypeof (l) != basetypeof (int))
5551 ltmp = ((typeof (l)) 1) / ltmp;
5555 rtmp = -(rtmp >> 1);
5563 if ((rtmp >>= 1) == 0)
5572 Note that some of the above is compile-time collapsable, such as
5573 the first part of the if statements that checks the base type of
5574 l against int. The if statements are phrased that way to suggest
5575 an easy way to generate the if/else constructs here, knowing that
5576 the back end should (and probably does) eliminate the resulting
5577 dead code (either the int case or the non-int case), something
5578 it couldn't do without the redundant phrasing, requiring explicit
5579 dead-code elimination here, which would be kind of difficult to
5586 tree basetypeof_l_is_int
;
5591 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5593 se
= expand_start_stmt_expr ();
5595 ffecom_start_compstmt ();
5598 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5599 FFETARGET_charactersizeNONE
, -1);
5600 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5601 FFETARGET_charactersizeNONE
, -1);
5602 result
= ffecom_make_tempvar ("power_res", ltype
,
5603 FFETARGET_charactersizeNONE
, -1);
5604 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5605 || TREE_CODE (ltype
) == RECORD_TYPE
)
5606 divide
= ffecom_make_tempvar ("power_div", ltype
,
5607 FFETARGET_charactersizeNONE
, -1);
5614 hook
= ffebld_nonter_hook (expr
);
5616 assert (TREE_CODE (hook
) == TREE_VEC
);
5617 assert (TREE_VEC_LENGTH (hook
) == 4);
5618 rtmp
= TREE_VEC_ELT (hook
, 0);
5619 ltmp
= TREE_VEC_ELT (hook
, 1);
5620 result
= TREE_VEC_ELT (hook
, 2);
5621 divide
= TREE_VEC_ELT (hook
, 3);
5622 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5623 || TREE_CODE (ltype
) == RECORD_TYPE
)
5630 expand_expr_stmt (ffecom_modify (void_type_node
,
5633 expand_expr_stmt (ffecom_modify (void_type_node
,
5636 expand_start_cond (ffecom_truth_value
5637 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5639 convert (rtype
, integer_zero_node
))),
5641 expand_expr_stmt (ffecom_modify (void_type_node
,
5643 convert (ltype
, integer_one_node
)));
5644 expand_start_else ();
5645 if (! integer_zerop (basetypeof_l_is_int
))
5647 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5650 integer_zero_node
)),
5652 expand_expr_stmt (ffecom_modify (void_type_node
,
5656 convert (ltype
, integer_one_node
),
5658 NULL_TREE
, NULL
, NULL
,
5660 expand_start_cond (ffecom_truth_value
5661 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5662 ffecom_2 (LT_EXPR
, integer_type_node
,
5665 integer_zero_node
)),
5666 ffecom_2 (EQ_EXPR
, integer_type_node
,
5667 ffecom_2 (BIT_AND_EXPR
,
5669 ffecom_1 (NEGATE_EXPR
,
5675 integer_zero_node
)))),
5677 expand_expr_stmt (ffecom_modify (void_type_node
,
5679 ffecom_1 (NEGATE_EXPR
,
5683 expand_start_else ();
5685 expand_expr_stmt (ffecom_modify (void_type_node
,
5687 convert (ltype
, integer_one_node
)));
5688 expand_start_cond (ffecom_truth_value
5689 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5690 ffecom_truth_value_invert
5691 (basetypeof_l_is_int
),
5692 ffecom_2 (LT_EXPR
, integer_type_node
,
5695 integer_zero_node
)))),
5697 expand_expr_stmt (ffecom_modify (void_type_node
,
5701 convert (ltype
, integer_one_node
),
5703 NULL_TREE
, NULL
, NULL
,
5705 expand_expr_stmt (ffecom_modify (void_type_node
,
5707 ffecom_1 (NEGATE_EXPR
, rtype
,
5709 expand_start_cond (ffecom_truth_value
5710 (ffecom_2 (LT_EXPR
, integer_type_node
,
5712 convert (rtype
, integer_zero_node
))),
5714 expand_expr_stmt (ffecom_modify (void_type_node
,
5716 ffecom_1 (NEGATE_EXPR
, rtype
,
5717 ffecom_2 (RSHIFT_EXPR
,
5720 integer_one_node
))));
5721 expand_expr_stmt (ffecom_modify (void_type_node
,
5723 ffecom_2 (MULT_EXPR
, ltype
,
5728 expand_start_loop (1);
5729 expand_start_cond (ffecom_truth_value
5730 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5732 convert (rtype
, integer_one_node
))),
5734 expand_expr_stmt (ffecom_modify (void_type_node
,
5736 ffecom_2 (MULT_EXPR
, ltype
,
5740 expand_exit_loop_if_false (NULL
,
5742 (ffecom_modify (rtype
,
5744 ffecom_2 (RSHIFT_EXPR
,
5747 integer_one_node
))));
5748 expand_expr_stmt (ffecom_modify (void_type_node
,
5750 ffecom_2 (MULT_EXPR
, ltype
,
5755 if (!integer_zerop (basetypeof_l_is_int
))
5757 expand_expr_stmt (result
);
5759 t
= ffecom_end_compstmt ();
5761 result
= expand_end_stmt_expr (se
);
5763 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5765 if (TREE_CODE (t
) == BLOCK
)
5767 /* Make a BIND_EXPR for the BLOCK already made. */
5768 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5769 NULL_TREE
, result
, t
);
5770 /* Remove the block from the tree at this point.
5771 It gets put back at the proper place
5772 when the BIND_EXPR is expanded. */
5782 /* ffecom_expr_transform_ -- Transform symbols in expr
5784 ffebld expr; // FFE expression.
5785 ffecom_expr_transform_ (expr);
5787 Recursive descent on expr while transforming any untransformed SYMTERs. */
5790 ffecom_expr_transform_ (ffebld expr
)
5800 switch (ffebld_op (expr
))
5802 case FFEBLD_opSYMTER
:
5803 s
= ffebld_symter (expr
);
5804 t
= ffesymbol_hook (s
).decl_tree
;
5805 if ((t
== NULL_TREE
)
5806 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5807 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5808 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5810 s
= ffecom_sym_transform_ (s
);
5811 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5814 break; /* Ok if (t == NULL) here. */
5817 ffecom_expr_transform_ (ffebld_head (expr
));
5818 expr
= ffebld_trail (expr
);
5819 goto tail_recurse
; /* :::::::::::::::::::: */
5825 switch (ffebld_arity (expr
))
5828 ffecom_expr_transform_ (ffebld_left (expr
));
5829 expr
= ffebld_right (expr
);
5830 goto tail_recurse
; /* :::::::::::::::::::: */
5833 expr
= ffebld_left (expr
);
5834 goto tail_recurse
; /* :::::::::::::::::::: */
5843 /* Make a type based on info in live f2c.h file. */
5846 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5850 case FFECOM_f2ccodeCHAR
:
5851 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5854 case FFECOM_f2ccodeSHORT
:
5855 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5858 case FFECOM_f2ccodeINT
:
5859 *type
= make_signed_type (INT_TYPE_SIZE
);
5862 case FFECOM_f2ccodeLONG
:
5863 *type
= make_signed_type (LONG_TYPE_SIZE
);
5866 case FFECOM_f2ccodeLONGLONG
:
5867 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5870 case FFECOM_f2ccodeCHARPTR
:
5871 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5872 ? signed_char_type_node
5873 : unsigned_char_type_node
);
5876 case FFECOM_f2ccodeFLOAT
:
5877 *type
= make_node (REAL_TYPE
);
5878 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5879 layout_type (*type
);
5882 case FFECOM_f2ccodeDOUBLE
:
5883 *type
= make_node (REAL_TYPE
);
5884 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5885 layout_type (*type
);
5888 case FFECOM_f2ccodeLONGDOUBLE
:
5889 *type
= make_node (REAL_TYPE
);
5890 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5891 layout_type (*type
);
5894 case FFECOM_f2ccodeTWOREALS
:
5895 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5898 case FFECOM_f2ccodeTWODOUBLEREALS
:
5899 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5903 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5904 *type
= error_mark_node
;
5908 pushdecl (build_decl (TYPE_DECL
,
5909 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5913 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5917 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
5923 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
5924 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
5925 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
5927 assert (code
!= -1);
5928 ffecom_f2c_typecode_
[bt
][j
] = code
;
5933 /* Finish up globals after doing all program units in file
5935 Need to handle only uninitialized COMMON areas. */
5938 ffecom_finish_global_ (ffeglobal global
)
5944 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
5947 if (ffeglobal_common_init (global
))
5950 cbt
= ffeglobal_hook (global
);
5951 if ((cbt
== NULL_TREE
)
5952 || !ffeglobal_common_have_size (global
))
5953 return global
; /* No need to make common, never ref'd. */
5955 DECL_EXTERNAL (cbt
) = 0;
5957 /* Give the array a size now. */
5959 size
= build_int_2 ((ffeglobal_common_size (global
)
5960 + ffeglobal_common_pad (global
)) - 1,
5963 cbtype
= TREE_TYPE (cbt
);
5964 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
5967 if (!TREE_TYPE (size
))
5968 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
5969 layout_type (cbtype
);
5971 cbt
= start_decl (cbt
, FALSE
);
5972 assert (cbt
== ffeglobal_hook (global
));
5974 finish_decl (cbt
, NULL_TREE
, FALSE
);
5979 /* Finish up any untransformed symbols. */
5982 ffecom_finish_symbol_transform_ (ffesymbol s
)
5984 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
5987 /* It's easy to know to transform an untransformed symbol, to make sure
5988 we put out debugging info for it. But COMMON variables, unlike
5989 EQUIVALENCE ones, aren't given declarations in addition to the
5990 tree expressions that specify offsets, because COMMON variables
5991 can be referenced in the outer scope where only dummy arguments
5992 (PARM_DECLs) should really be seen. To be safe, just don't do any
5993 VAR_DECLs for COMMON variables when we transform them for real
5994 use, and therefore we do all the VAR_DECL creating here. */
5996 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
5998 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
5999 || (ffesymbol_where (s
) != FFEINFO_whereNONE
6000 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
6001 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6002 /* Not transformed, and not CHARACTER*(*), and not a dummy
6003 argument, which can happen only if the entry point names
6004 it "rides in on" are all invalidated for other reasons. */
6005 s
= ffecom_sym_transform_ (s
);
6008 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6009 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6011 /* This isn't working, at least for dbxout. The .s file looks
6012 okay to me (burley), but in gdb 4.9 at least, the variables
6013 appear to reside somewhere outside of the common area, so
6014 it doesn't make sense to mislead anyone by generating the info
6015 on those variables until this is fixed. NOTE: Same problem
6016 with EQUIVALENCE, sadly...see similar #if later. */
6017 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6018 ffesymbol_storage (s
));
6024 /* Append underscore(s) to name before calling get_identifier. "us"
6025 is nonzero if the name already contains an underscore and thus
6026 needs two underscores appended. */
6029 ffecom_get_appended_identifier_ (char us
, const char *name
)
6035 newname
= xmalloc ((i
= strlen (name
)) + 1
6036 + ffe_is_underscoring ()
6038 memcpy (newname
, name
, i
);
6040 newname
[i
+ us
] = '_';
6041 newname
[i
+ 1 + us
] = '\0';
6042 id
= get_identifier (newname
);
6049 /* Decide whether to append underscore to name before calling
6053 ffecom_get_external_identifier_ (ffesymbol s
)
6056 const char *name
= ffesymbol_text (s
);
6058 /* If name is a built-in name, just return it as is. */
6060 if (!ffe_is_underscoring ()
6061 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6062 #if FFETARGET_isENFORCED_MAIN_NAME
6063 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6065 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6067 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6068 return get_identifier (name
);
6070 us
= ffe_is_second_underscore ()
6071 ? (strchr (name
, '_') != NULL
)
6074 return ffecom_get_appended_identifier_ (us
, name
);
6077 /* Decide whether to append underscore to internal name before calling
6080 This is for non-external, top-function-context names only. Transform
6081 identifier so it doesn't conflict with the transformed result
6082 of using a _different_ external name. E.g. if "CALL FOO" is
6083 transformed into "FOO_();", then the variable in "FOO_ = 3"
6084 must be transformed into something that does not conflict, since
6085 these two things should be independent.
6087 The transformation is as follows. If the name does not contain
6088 an underscore, there is no possible conflict, so just return.
6089 If the name does contain an underscore, then transform it just
6090 like we transform an external identifier. */
6093 ffecom_get_identifier_ (const char *name
)
6095 /* If name does not contain an underscore, just return it as is. */
6097 if (!ffe_is_underscoring ()
6098 || (strchr (name
, '_') == NULL
))
6099 return get_identifier (name
);
6101 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6105 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6108 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6109 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6110 ffesymbol_kindtype(s));
6112 Call after setting up containing function and getting trees for all
6116 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6118 ffebld expr
= ffesymbol_sfexpr (s
);
6122 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6123 static bool recurse
= FALSE
;
6124 int old_lineno
= lineno
;
6125 const char *old_input_filename
= input_filename
;
6127 ffecom_nested_entry_
= s
;
6129 /* For now, we don't have a handy pointer to where the sfunc is actually
6130 defined, though that should be easy to add to an ffesymbol. (The
6131 token/where info available might well point to the place where the type
6132 of the sfunc is declared, especially if that precedes the place where
6133 the sfunc itself is defined, which is typically the case.) We should
6134 put out a null pointer rather than point somewhere wrong, but I want to
6135 see how it works at this point. */
6137 input_filename
= ffesymbol_where_filename (s
);
6138 lineno
= ffesymbol_where_filelinenum (s
);
6140 /* Pretransform the expression so any newly discovered things belong to the
6141 outer program unit, not to the statement function. */
6143 ffecom_expr_transform_ (expr
);
6145 /* Make sure no recursive invocation of this fn (a specific case of failing
6146 to pretransform an sfunc's expression, i.e. where its expression
6147 references another untransformed sfunc) happens. */
6152 push_f_function_context ();
6155 type
= void_type_node
;
6158 type
= ffecom_tree_type
[bt
][kt
];
6159 if (type
== NULL_TREE
)
6160 type
= integer_type_node
; /* _sym_exec_transition reports
6164 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6165 build_function_type (type
, NULL_TREE
),
6166 1, /* nested/inline */
6167 0); /* TREE_PUBLIC */
6169 /* We don't worry about COMPLEX return values here, because this is
6170 entirely internal to our code, and gcc has the ability to return COMPLEX
6171 directly as a value. */
6174 { /* Prepend arg for where result goes. */
6177 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6179 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6181 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6183 type
= build_pointer_type (type
);
6184 result
= build_decl (PARM_DECL
, result
, type
);
6186 push_parm_decl (result
);
6189 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6191 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6193 store_parm_decls (0);
6195 ffecom_start_compstmt ();
6201 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6204 result_length
= build_int_2 (sz
, 0);
6205 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6207 ffecom_prepare_let_char_ (sz
, expr
);
6209 ffecom_prepare_end ();
6211 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6212 expand_null_return ();
6216 ffecom_prepare_expr (expr
);
6218 ffecom_prepare_end ();
6220 expand_return (ffecom_modify (NULL_TREE
,
6221 DECL_RESULT (current_function_decl
),
6222 ffecom_expr (expr
)));
6226 ffecom_end_compstmt ();
6228 func
= current_function_decl
;
6229 finish_function (1);
6231 pop_f_function_context ();
6235 lineno
= old_lineno
;
6236 input_filename
= old_input_filename
;
6238 ffecom_nested_entry_
= NULL
;
6244 ffecom_gfrt_args_ (ffecomGfrt ix
)
6246 return ffecom_gfrt_argstring_
[ix
];
6250 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6252 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6253 ffecom_make_gfrt_ (ix
);
6255 return ffecom_1 (ADDR_EXPR
,
6256 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6260 /* Return initialize-to-zero expression for this VAR_DECL. */
6262 /* A somewhat evil way to prevent the garbage collector
6263 from collecting 'tree' structures. */
6264 #define NUM_TRACKED_CHUNK 63
6265 static struct tree_ggc_tracker
6267 struct tree_ggc_tracker
*next
;
6268 tree trees
[NUM_TRACKED_CHUNK
];
6269 } *tracker_head
= NULL
;
6272 mark_tracker_head (void *arg
)
6274 struct tree_ggc_tracker
*head
;
6277 for (head
= * (struct tree_ggc_tracker
**) arg
;
6282 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6283 ggc_mark_tree (head
->trees
[i
]);
6288 ffecom_save_tree_forever (tree t
)
6291 if (tracker_head
!= NULL
)
6292 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6293 if (tracker_head
->trees
[i
] == NULL
)
6295 tracker_head
->trees
[i
] = t
;
6300 /* Need to allocate a new block. */
6301 struct tree_ggc_tracker
*old_head
= tracker_head
;
6303 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6304 tracker_head
->next
= old_head
;
6305 tracker_head
->trees
[0] = t
;
6306 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6307 tracker_head
->trees
[i
] = NULL
;
6312 ffecom_init_zero_ (tree decl
)
6315 int incremental
= TREE_STATIC (decl
);
6316 tree type
= TREE_TYPE (decl
);
6320 make_decl_rtl (decl
, NULL
);
6321 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6324 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6325 && (TREE_CODE (type
) != RECORD_TYPE
)
6326 && (TREE_CODE (type
) != UNION_TYPE
)
6328 init
= convert (type
, integer_zero_node
);
6329 else if (!incremental
)
6331 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6332 TREE_CONSTANT (init
) = 1;
6333 TREE_STATIC (init
) = 1;
6337 assemble_zeros (int_size_in_bytes (type
));
6338 init
= error_mark_node
;
6345 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6351 switch (ffebld_op (arg
))
6353 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6354 if (ffetarget_length_character1
6355 (ffebld_constant_character1
6356 (ffebld_conter (arg
))) == 0)
6358 *maybe_tree
= integer_zero_node
;
6359 return convert (tree_type
, integer_zero_node
);
6362 *maybe_tree
= integer_one_node
;
6363 expr_tree
= build_int_2 (*ffetarget_text_character1
6364 (ffebld_constant_character1
6365 (ffebld_conter (arg
))),
6367 TREE_TYPE (expr_tree
) = tree_type
;
6370 case FFEBLD_opSYMTER
:
6371 case FFEBLD_opARRAYREF
:
6372 case FFEBLD_opFUNCREF
:
6373 case FFEBLD_opSUBSTR
:
6374 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6376 if ((expr_tree
== error_mark_node
)
6377 || (length_tree
== error_mark_node
))
6379 *maybe_tree
= error_mark_node
;
6380 return error_mark_node
;
6383 if (integer_zerop (length_tree
))
6385 *maybe_tree
= integer_zero_node
;
6386 return convert (tree_type
, integer_zero_node
);
6390 = ffecom_1 (INDIRECT_REF
,
6391 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6394 = ffecom_2 (ARRAY_REF
,
6395 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6398 expr_tree
= convert (tree_type
, expr_tree
);
6400 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6401 *maybe_tree
= integer_one_node
;
6402 else /* Must check length at run time. */
6404 = ffecom_truth_value
6405 (ffecom_2 (GT_EXPR
, integer_type_node
,
6407 ffecom_f2c_ftnlen_zero_node
));
6410 case FFEBLD_opPAREN
:
6411 case FFEBLD_opCONVERT
:
6412 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6414 *maybe_tree
= integer_zero_node
;
6415 return convert (tree_type
, integer_zero_node
);
6417 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6420 case FFEBLD_opCONCATENATE
:
6427 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6429 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6431 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6434 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6442 assert ("bad op in ICHAR" == NULL
);
6443 return error_mark_node
;
6447 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6451 length_arg = ffecom_intrinsic_len_ (expr);
6453 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6454 subexpressions by constructing the appropriate tree for the
6455 length-of-character-text argument in a calling sequence. */
6458 ffecom_intrinsic_len_ (ffebld expr
)
6460 ffetargetCharacter1 val
;
6463 switch (ffebld_op (expr
))
6465 case FFEBLD_opCONTER
:
6466 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6467 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6468 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6471 case FFEBLD_opSYMTER
:
6473 ffesymbol s
= ffebld_symter (expr
);
6476 item
= ffesymbol_hook (s
).decl_tree
;
6477 if (item
== NULL_TREE
)
6479 s
= ffecom_sym_transform_ (s
);
6480 item
= ffesymbol_hook (s
).decl_tree
;
6482 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6484 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6485 length
= ffesymbol_hook (s
).length_tree
;
6488 length
= build_int_2 (ffesymbol_size (s
), 0);
6489 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6492 else if (item
== error_mark_node
)
6493 length
= error_mark_node
;
6494 else /* FFEINFO_kindFUNCTION: */
6499 case FFEBLD_opARRAYREF
:
6500 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6503 case FFEBLD_opSUBSTR
:
6507 ffebld thing
= ffebld_right (expr
);
6511 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6512 start
= ffebld_head (thing
);
6513 thing
= ffebld_trail (thing
);
6514 assert (ffebld_trail (thing
) == NULL
);
6515 end
= ffebld_head (thing
);
6517 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6519 if (length
== error_mark_node
)
6528 length
= convert (ffecom_f2c_ftnlen_type_node
,
6534 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6535 ffecom_expr (start
));
6537 if (start_tree
== error_mark_node
)
6539 length
= error_mark_node
;
6545 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6546 ffecom_f2c_ftnlen_one_node
,
6547 ffecom_2 (MINUS_EXPR
,
6548 ffecom_f2c_ftnlen_type_node
,
6554 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6557 if (end_tree
== error_mark_node
)
6559 length
= error_mark_node
;
6563 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6564 ffecom_f2c_ftnlen_one_node
,
6565 ffecom_2 (MINUS_EXPR
,
6566 ffecom_f2c_ftnlen_type_node
,
6567 end_tree
, start_tree
));
6573 case FFEBLD_opCONCATENATE
:
6575 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6576 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6577 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6580 case FFEBLD_opFUNCREF
:
6581 case FFEBLD_opCONVERT
:
6582 length
= build_int_2 (ffebld_size (expr
), 0);
6583 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6587 assert ("bad op for single char arg expr" == NULL
);
6588 length
= ffecom_f2c_ftnlen_zero_node
;
6592 assert (length
!= NULL_TREE
);
6597 /* Handle CHARACTER assignments.
6599 Generates code to do the assignment. Used by ordinary assignment
6600 statement handler ffecom_let_stmt and by statement-function
6601 handler to generate code for a statement function. */
6604 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6605 ffetargetCharacterSize dest_size
, ffebld source
)
6607 ffecomConcatList_ catlist
;
6612 if ((dest_tree
== error_mark_node
)
6613 || (dest_length
== error_mark_node
))
6616 assert (dest_tree
!= NULL_TREE
);
6617 assert (dest_length
!= NULL_TREE
);
6619 /* Source might be an opCONVERT, which just means it is a different size
6620 than the destination. Since the underlying implementation here handles
6621 that (directly or via the s_copy or s_cat run-time-library functions),
6622 we don't need the "convenience" of an opCONVERT that tells us to
6623 truncate or blank-pad, particularly since the resulting implementation
6624 would probably be slower than otherwise. */
6626 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6627 source
= ffebld_left (source
);
6629 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6630 switch (ffecom_concat_list_count_ (catlist
))
6632 case 0: /* Shouldn't happen, but in case it does... */
6633 ffecom_concat_list_kill_ (catlist
);
6634 source_tree
= null_pointer_node
;
6635 source_length
= ffecom_f2c_ftnlen_zero_node
;
6636 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6637 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6638 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6639 = build_tree_list (NULL_TREE
, dest_length
);
6640 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6641 = build_tree_list (NULL_TREE
, source_length
);
6643 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6644 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6646 expand_expr_stmt (expr_tree
);
6650 case 1: /* The (fairly) easy case. */
6651 ffecom_char_args_ (&source_tree
, &source_length
,
6652 ffecom_concat_list_expr_ (catlist
, 0));
6653 ffecom_concat_list_kill_ (catlist
);
6654 assert (source_tree
!= NULL_TREE
);
6655 assert (source_length
!= NULL_TREE
);
6657 if ((source_tree
== error_mark_node
)
6658 || (source_length
== error_mark_node
))
6664 = ffecom_1 (INDIRECT_REF
,
6665 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6669 = ffecom_2 (ARRAY_REF
,
6670 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6675 = ffecom_1 (INDIRECT_REF
,
6676 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6680 = ffecom_2 (ARRAY_REF
,
6681 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6686 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6688 expand_expr_stmt (expr_tree
);
6693 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6694 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6695 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6696 = build_tree_list (NULL_TREE
, dest_length
);
6697 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6698 = build_tree_list (NULL_TREE
, source_length
);
6700 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6701 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6703 expand_expr_stmt (expr_tree
);
6707 default: /* Must actually concatenate things. */
6711 /* Heavy-duty concatenation. */
6714 int count
= ffecom_concat_list_count_ (catlist
);
6726 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
6727 FFETARGET_charactersizeNONE
, count
, TRUE
);
6728 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
6729 FFETARGET_charactersizeNONE
,
6735 hook
= ffebld_nonter_hook (source
);
6737 assert (TREE_CODE (hook
) == TREE_VEC
);
6738 assert (TREE_VEC_LENGTH (hook
) == 2);
6739 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6740 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6744 for (i
= 0; i
< count
; ++i
)
6746 ffecom_char_args_ (&citem
, &clength
,
6747 ffecom_concat_list_expr_ (catlist
, i
));
6748 if ((citem
== error_mark_node
)
6749 || (clength
== error_mark_node
))
6751 ffecom_concat_list_kill_ (catlist
);
6756 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6757 ffecom_modify (void_type_node
,
6758 ffecom_2 (ARRAY_REF
,
6759 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6761 build_int_2 (i
, 0)),
6765 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6766 ffecom_modify (void_type_node
,
6767 ffecom_2 (ARRAY_REF
,
6768 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6770 build_int_2 (i
, 0)),
6775 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6776 TREE_CHAIN (expr_tree
)
6777 = build_tree_list (NULL_TREE
,
6778 ffecom_1 (ADDR_EXPR
,
6779 build_pointer_type (TREE_TYPE (items
)),
6781 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6782 = build_tree_list (NULL_TREE
,
6783 ffecom_1 (ADDR_EXPR
,
6784 build_pointer_type (TREE_TYPE (lengths
)),
6786 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6789 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6790 convert (ffecom_f2c_ftnlen_type_node
,
6791 build_int_2 (count
, 0))));
6792 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6793 = build_tree_list (NULL_TREE
, dest_length
);
6795 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6796 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6798 expand_expr_stmt (expr_tree
);
6801 ffecom_concat_list_kill_ (catlist
);
6804 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6807 ffecom_make_gfrt_(ix);
6809 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6810 for the indicated run-time routine (ix). */
6813 ffecom_make_gfrt_ (ffecomGfrt ix
)
6818 switch (ffecom_gfrt_type_
[ix
])
6820 case FFECOM_rttypeVOID_
:
6821 ttype
= void_type_node
;
6824 case FFECOM_rttypeVOIDSTAR_
:
6825 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6828 case FFECOM_rttypeFTNINT_
:
6829 ttype
= ffecom_f2c_ftnint_type_node
;
6832 case FFECOM_rttypeINTEGER_
:
6833 ttype
= ffecom_f2c_integer_type_node
;
6836 case FFECOM_rttypeLONGINT_
:
6837 ttype
= ffecom_f2c_longint_type_node
;
6840 case FFECOM_rttypeLOGICAL_
:
6841 ttype
= ffecom_f2c_logical_type_node
;
6844 case FFECOM_rttypeREAL_F2C_
:
6845 ttype
= double_type_node
;
6848 case FFECOM_rttypeREAL_GNU_
:
6849 ttype
= float_type_node
;
6852 case FFECOM_rttypeCOMPLEX_F2C_
:
6853 ttype
= void_type_node
;
6856 case FFECOM_rttypeCOMPLEX_GNU_
:
6857 ttype
= ffecom_f2c_complex_type_node
;
6860 case FFECOM_rttypeDOUBLE_
:
6861 ttype
= double_type_node
;
6864 case FFECOM_rttypeDOUBLEREAL_
:
6865 ttype
= ffecom_f2c_doublereal_type_node
;
6868 case FFECOM_rttypeDBLCMPLX_F2C_
:
6869 ttype
= void_type_node
;
6872 case FFECOM_rttypeDBLCMPLX_GNU_
:
6873 ttype
= ffecom_f2c_doublecomplex_type_node
;
6876 case FFECOM_rttypeCHARACTER_
:
6877 ttype
= void_type_node
;
6882 assert ("bad rttype" == NULL
);
6886 ttype
= build_function_type (ttype
, NULL_TREE
);
6887 t
= build_decl (FUNCTION_DECL
,
6888 get_identifier (ffecom_gfrt_name_
[ix
]),
6890 DECL_EXTERNAL (t
) = 1;
6891 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6892 TREE_PUBLIC (t
) = 1;
6893 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6895 /* Sanity check: A function that's const cannot be volatile. */
6897 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
6899 /* Sanity check: A function that's const cannot return complex. */
6901 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
6903 t
= start_decl (t
, TRUE
);
6905 finish_decl (t
, NULL_TREE
, TRUE
);
6907 ffecom_gfrt_
[ix
] = t
;
6910 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6913 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
6915 ffesymbol s
= ffestorag_symbol (st
);
6917 if (ffesymbol_namelisted (s
))
6918 ffecom_member_namelisted_
= TRUE
;
6921 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6922 the member so debugger will see it. Otherwise nobody should be
6923 referencing the member. */
6926 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
6934 || ((mt
= ffestorag_hook (mst
)) == NULL
)
6935 || (mt
== error_mark_node
))
6939 || ((s
= ffestorag_symbol (st
)) == NULL
))
6942 type
= ffecom_type_localvar_ (s
,
6943 ffesymbol_basictype (s
),
6944 ffesymbol_kindtype (s
));
6945 if (type
== error_mark_node
)
6948 t
= build_decl (VAR_DECL
,
6949 ffecom_get_identifier_ (ffesymbol_text (s
)),
6952 TREE_STATIC (t
) = TREE_STATIC (mt
);
6953 DECL_INITIAL (t
) = NULL_TREE
;
6954 TREE_ASM_WRITTEN (t
) = 1;
6958 gen_rtx (MEM
, TYPE_MODE (type
),
6959 plus_constant (XEXP (DECL_RTL (mt
), 0),
6960 ffestorag_modulo (mst
)
6961 + ffestorag_offset (st
)
6962 - ffestorag_offset (mst
))));
6964 t
= start_decl (t
, FALSE
);
6966 finish_decl (t
, NULL_TREE
, FALSE
);
6969 /* Prepare source expression for assignment into a destination perhaps known
6970 to be of a specific size. */
6973 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
6975 ffecomConcatList_ catlist
;
6980 tree tempvar
= NULL_TREE
;
6982 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6983 source
= ffebld_left (source
);
6985 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6986 count
= ffecom_concat_list_count_ (catlist
);
6991 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
6992 FFETARGET_charactersizeNONE
, count
);
6994 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
6995 FFETARGET_charactersizeNONE
, count
);
6997 tempvar
= make_tree_vec (2);
6998 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
6999 TREE_VEC_ELT (tempvar
, 1) = itmp
;
7002 for (i
= 0; i
< count
; ++i
)
7003 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
7005 ffecom_concat_list_kill_ (catlist
);
7009 ffebld_nonter_set_hook (source
, tempvar
);
7010 current_binding_level
->prep_state
= 1;
7014 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7016 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7017 (which generates their trees) and then their trees get push_parm_decl'd.
7019 The second arg is TRUE if the dummies are for a statement function, in
7020 which case lengths are not pushed for character arguments (since they are
7021 always known by both the caller and the callee, though the code allows
7022 for someday permitting CHAR*(*) stmtfunc dummies). */
7025 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7032 ffecom_transform_only_dummies_
= TRUE
;
7034 /* First push the parms corresponding to actual dummy "contents". */
7036 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7038 dummy
= ffebld_head (dumlist
);
7039 switch (ffebld_op (dummy
))
7043 continue; /* Forget alternate returns. */
7048 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7049 s
= ffebld_symter (dummy
);
7050 parm
= ffesymbol_hook (s
).decl_tree
;
7051 if (parm
== NULL_TREE
)
7053 s
= ffecom_sym_transform_ (s
);
7054 parm
= ffesymbol_hook (s
).decl_tree
;
7055 assert (parm
!= NULL_TREE
);
7057 if (parm
!= error_mark_node
)
7058 push_parm_decl (parm
);
7061 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7063 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7065 dummy
= ffebld_head (dumlist
);
7066 switch (ffebld_op (dummy
))
7070 continue; /* Forget alternate returns, they mean
7076 s
= ffebld_symter (dummy
);
7077 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7078 continue; /* Only looking for CHARACTER arguments. */
7079 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7080 continue; /* Stmtfunc arg with known size needs no
7082 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7083 continue; /* Only looking for variables and arrays. */
7084 parm
= ffesymbol_hook (s
).length_tree
;
7085 assert (parm
!= NULL_TREE
);
7086 if (parm
!= error_mark_node
)
7087 push_parm_decl (parm
);
7090 ffecom_transform_only_dummies_
= FALSE
;
7093 /* ffecom_start_progunit_ -- Beginning of program unit
7095 Does GNU back end stuff necessary to teach it about the start of its
7096 equivalent of a Fortran program unit. */
7099 ffecom_start_progunit_ ()
7101 ffesymbol fn
= ffecom_primary_entry_
;
7103 tree id
; /* Identifier (name) of function. */
7104 tree type
; /* Type of function. */
7105 tree result
; /* Result of function. */
7106 ffeinfoBasictype bt
;
7110 ffeglobalType egt
= FFEGLOBAL_type
;
7113 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7116 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7117 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7118 bool main_program
= FALSE
;
7119 int old_lineno
= lineno
;
7120 const char *old_input_filename
= input_filename
;
7122 assert (fn
!= NULL
);
7123 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7125 input_filename
= ffesymbol_where_filename (fn
);
7126 lineno
= ffesymbol_where_filelinenum (fn
);
7128 switch (ffecom_primary_entry_kind_
)
7130 case FFEINFO_kindPROGRAM
:
7131 main_program
= TRUE
;
7132 gt
= FFEGLOBAL_typeMAIN
;
7133 bt
= FFEINFO_basictypeNONE
;
7134 kt
= FFEINFO_kindtypeNONE
;
7135 type
= ffecom_tree_fun_type_void
;
7140 case FFEINFO_kindBLOCKDATA
:
7141 gt
= FFEGLOBAL_typeBDATA
;
7142 bt
= FFEINFO_basictypeNONE
;
7143 kt
= FFEINFO_kindtypeNONE
;
7144 type
= ffecom_tree_fun_type_void
;
7149 case FFEINFO_kindFUNCTION
:
7150 gt
= FFEGLOBAL_typeFUNC
;
7151 egt
= FFEGLOBAL_typeEXT
;
7152 bt
= ffesymbol_basictype (fn
);
7153 kt
= ffesymbol_kindtype (fn
);
7154 if (bt
== FFEINFO_basictypeNONE
)
7156 ffeimplic_establish_symbol (fn
);
7157 if (ffesymbol_funcresult (fn
) != NULL
)
7158 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7159 bt
= ffesymbol_basictype (fn
);
7160 kt
= ffesymbol_kindtype (fn
);
7164 charfunc
= cmplxfunc
= FALSE
;
7165 else if (bt
== FFEINFO_basictypeCHARACTER
)
7166 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7167 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7168 && ffesymbol_is_f2c (fn
)
7170 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7172 charfunc
= cmplxfunc
= FALSE
;
7174 if (multi
|| charfunc
)
7175 type
= ffecom_tree_fun_type_void
;
7176 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7177 type
= ffecom_tree_fun_type
[bt
][kt
];
7179 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7181 if ((type
== NULL_TREE
)
7182 || (TREE_TYPE (type
) == NULL_TREE
))
7183 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7186 case FFEINFO_kindSUBROUTINE
:
7187 gt
= FFEGLOBAL_typeSUBR
;
7188 egt
= FFEGLOBAL_typeEXT
;
7189 bt
= FFEINFO_basictypeNONE
;
7190 kt
= FFEINFO_kindtypeNONE
;
7191 if (ffecom_is_altreturning_
)
7192 type
= ffecom_tree_subr_type
;
7194 type
= ffecom_tree_fun_type_void
;
7200 assert ("say what??" == NULL
);
7202 case FFEINFO_kindANY
:
7203 gt
= FFEGLOBAL_typeANY
;
7204 bt
= FFEINFO_basictypeNONE
;
7205 kt
= FFEINFO_kindtypeNONE
;
7206 type
= error_mark_node
;
7214 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7215 ffesymbol_text (fn
));
7217 #if FFETARGET_isENFORCED_MAIN
7218 else if (main_program
)
7219 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7222 id
= ffecom_get_external_identifier_ (fn
);
7226 0, /* nested/inline */
7227 !altentries
); /* TREE_PUBLIC */
7229 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7232 && ((g
= ffesymbol_global (fn
)) != NULL
)
7233 && ((ffeglobal_type (g
) == gt
)
7234 || (ffeglobal_type (g
) == egt
)))
7236 ffeglobal_set_hook (g
, current_function_decl
);
7239 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7240 exec-transitioning needs current_function_decl to be filled in. So we
7241 do these things in two phases. */
7244 { /* 1st arg identifies which entrypoint. */
7245 ffecom_which_entrypoint_decl_
7246 = build_decl (PARM_DECL
,
7247 ffecom_get_invented_identifier ("__g77_%s",
7248 "which_entrypoint"),
7250 push_parm_decl (ffecom_which_entrypoint_decl_
);
7256 { /* Arg for result (return value). */
7261 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7263 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7265 type
= ffecom_multi_type_node_
;
7267 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7269 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7272 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7274 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7276 type
= build_pointer_type (type
);
7277 result
= build_decl (PARM_DECL
, result
, type
);
7279 push_parm_decl (result
);
7281 ffecom_multi_retval_
= result
;
7283 ffecom_func_result_
= result
;
7287 push_parm_decl (length
);
7288 ffecom_func_length_
= length
;
7292 if (ffecom_primary_entry_is_proc_
)
7295 arglist
= ffecom_master_arglist_
;
7297 arglist
= ffesymbol_dummyargs (fn
);
7298 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7301 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7302 store_parm_decls (main_program
? 1 : 0);
7304 ffecom_start_compstmt ();
7305 /* Disallow temp vars at this level. */
7306 current_binding_level
->prep_state
= 2;
7308 lineno
= old_lineno
;
7309 input_filename
= old_input_filename
;
7311 /* This handles any symbols still untransformed, in case -g specified.
7312 This used to be done in ffecom_finish_progunit, but it turns out to
7313 be necessary to do it here so that statement functions are
7314 expanded before code. But don't bother for BLOCK DATA. */
7316 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7317 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7320 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7323 ffecom_sym_transform_(s);
7325 The ffesymbol_hook info for s is updated with appropriate backend info
7329 ffecom_sym_transform_ (ffesymbol s
)
7331 tree t
; /* Transformed thingy. */
7332 tree tlen
; /* Length if CHAR*(*). */
7333 bool addr
; /* Is t the address of the thingy? */
7334 ffeinfoBasictype bt
;
7337 int old_lineno
= lineno
;
7338 const char *old_input_filename
= input_filename
;
7340 /* Must ensure special ASSIGN variables are declared at top of outermost
7341 block, else they'll end up in the innermost block when their first
7342 ASSIGN is seen, which leaves them out of scope when they're the
7343 subject of a GOTO or I/O statement.
7345 We make this variable even if -fugly-assign. Just let it go unused,
7346 in case it turns out there are cases where we really want to use this
7347 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7349 if (! ffecom_transform_only_dummies_
7350 && ffesymbol_assigned (s
)
7351 && ! ffesymbol_hook (s
).assign_tree
)
7352 s
= ffecom_sym_transform_assign_ (s
);
7354 if (ffesymbol_sfdummyparent (s
) == NULL
)
7356 input_filename
= ffesymbol_where_filename (s
);
7357 lineno
= ffesymbol_where_filelinenum (s
);
7361 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7363 input_filename
= ffesymbol_where_filename (sf
);
7364 lineno
= ffesymbol_where_filelinenum (sf
);
7367 bt
= ffeinfo_basictype (ffebld_info (s
));
7368 kt
= ffeinfo_kindtype (ffebld_info (s
));
7374 switch (ffesymbol_kind (s
))
7376 case FFEINFO_kindNONE
:
7377 switch (ffesymbol_where (s
))
7379 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7380 assert (ffecom_transform_only_dummies_
);
7382 /* Before 0.4, this could be ENTITY/DUMMY, but see
7383 ffestu_sym_end_transition -- no longer true (in particular, if
7384 it could be an ENTITY, it _will_ be made one, so that
7385 possibility won't come through here). So we never make length
7386 arg for CHARACTER type. */
7388 t
= build_decl (PARM_DECL
,
7389 ffecom_get_identifier_ (ffesymbol_text (s
)),
7390 ffecom_tree_ptr_to_subr_type
);
7391 DECL_ARTIFICIAL (t
) = 1;
7395 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7396 assert (!ffecom_transform_only_dummies_
);
7398 if (((g
= ffesymbol_global (s
)) != NULL
)
7399 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7400 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7401 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7402 && (ffeglobal_hook (g
) != NULL_TREE
)
7403 && ffe_is_globals ())
7405 t
= ffeglobal_hook (g
);
7409 t
= build_decl (FUNCTION_DECL
,
7410 ffecom_get_external_identifier_ (s
),
7411 ffecom_tree_subr_type
); /* Assume subr. */
7412 DECL_EXTERNAL (t
) = 1;
7413 TREE_PUBLIC (t
) = 1;
7415 t
= start_decl (t
, FALSE
);
7416 finish_decl (t
, NULL_TREE
, FALSE
);
7419 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7420 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7421 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7422 ffeglobal_set_hook (g
, t
);
7424 ffecom_save_tree_forever (t
);
7429 assert ("NONE where unexpected" == NULL
);
7431 case FFEINFO_whereANY
:
7436 case FFEINFO_kindENTITY
:
7437 switch (ffeinfo_where (ffesymbol_info (s
)))
7440 case FFEINFO_whereCONSTANT
:
7441 /* ~~Debugging info needed? */
7442 assert (!ffecom_transform_only_dummies_
);
7443 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7446 case FFEINFO_whereLOCAL
:
7447 assert (!ffecom_transform_only_dummies_
);
7450 ffestorag st
= ffesymbol_storage (s
);
7454 && (ffestorag_size (st
) == 0))
7456 t
= error_mark_node
;
7460 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7462 if (type
== error_mark_node
)
7464 t
= error_mark_node
;
7469 && (ffestorag_parent (st
) != NULL
))
7470 { /* Child of EQUIVALENCE parent. */
7473 ffetargetOffset offset
;
7475 est
= ffestorag_parent (st
);
7476 ffecom_transform_equiv_ (est
);
7478 et
= ffestorag_hook (est
);
7479 assert (et
!= NULL_TREE
);
7481 if (! TREE_STATIC (et
))
7482 put_var_into_stack (et
);
7484 offset
= ffestorag_modulo (est
)
7485 + ffestorag_offset (ffesymbol_storage (s
))
7486 - ffestorag_offset (est
);
7488 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7490 /* (t_type *) (((char *) &et) + offset) */
7492 t
= convert (string_type_node
, /* (char *) */
7493 ffecom_1 (ADDR_EXPR
,
7494 build_pointer_type (TREE_TYPE (et
)),
7496 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7498 build_int_2 (offset
, 0));
7499 t
= convert (build_pointer_type (type
),
7501 TREE_CONSTANT (t
) = staticp (et
);
7508 bool init
= ffesymbol_is_init (s
);
7510 t
= build_decl (VAR_DECL
,
7511 ffecom_get_identifier_ (ffesymbol_text (s
)),
7515 || ffesymbol_namelisted (s
)
7516 #ifdef FFECOM_sizeMAXSTACKITEM
7518 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7520 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7521 && (ffecom_primary_entry_kind_
7522 != FFEINFO_kindBLOCKDATA
)
7523 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7524 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7526 TREE_STATIC (t
) = 0; /* No need to make static. */
7528 if (init
|| ffe_is_init_local_zero ())
7529 DECL_INITIAL (t
) = error_mark_node
;
7531 /* Keep -Wunused from complaining about var if it
7532 is used as sfunc arg or DATA implied-DO. */
7533 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7534 DECL_IN_SYSTEM_HEADER (t
) = 1;
7536 t
= start_decl (t
, FALSE
);
7540 if (ffesymbol_init (s
) != NULL
)
7541 initexpr
= ffecom_expr (ffesymbol_init (s
));
7543 initexpr
= ffecom_init_zero_ (t
);
7545 else if (ffe_is_init_local_zero ())
7546 initexpr
= ffecom_init_zero_ (t
);
7548 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7550 finish_decl (t
, initexpr
, FALSE
);
7552 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7554 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7555 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7556 ffestorag_size (st
)));
7562 case FFEINFO_whereRESULT
:
7563 assert (!ffecom_transform_only_dummies_
);
7565 if (bt
== FFEINFO_basictypeCHARACTER
)
7566 { /* Result is already in list of dummies, use
7568 t
= ffecom_func_result_
;
7569 tlen
= ffecom_func_length_
;
7573 if ((ffecom_num_entrypoints_
== 0)
7574 && (bt
== FFEINFO_basictypeCOMPLEX
)
7575 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7576 { /* Result is already in list of dummies, use
7578 t
= ffecom_func_result_
;
7582 if (ffecom_func_result_
!= NULL_TREE
)
7584 t
= ffecom_func_result_
;
7587 if ((ffecom_num_entrypoints_
!= 0)
7588 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7590 assert (ffecom_multi_retval_
!= NULL_TREE
);
7591 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7592 ffecom_multi_retval_
);
7593 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7594 t
, ffecom_multi_fields_
[bt
][kt
]);
7599 t
= build_decl (VAR_DECL
,
7600 ffecom_get_identifier_ (ffesymbol_text (s
)),
7601 ffecom_tree_type
[bt
][kt
]);
7602 TREE_STATIC (t
) = 0; /* Put result on stack. */
7603 t
= start_decl (t
, FALSE
);
7604 finish_decl (t
, NULL_TREE
, FALSE
);
7606 ffecom_func_result_
= t
;
7610 case FFEINFO_whereDUMMY
:
7618 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7620 type
= ffecom_tree_type
[bt
][kt
];
7621 if (ffesymbol_sfdummyparent (s
) != NULL
)
7623 if (current_function_decl
== ffecom_outer_function_decl_
)
7624 { /* Exec transition before sfunc
7625 context; get it later. */
7628 t
= ffecom_get_identifier_ (ffesymbol_text
7629 (ffesymbol_sfdummyparent (s
)));
7632 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7634 assert (ffecom_transform_only_dummies_
);
7636 old_sizes
= get_pending_sizes ();
7637 put_pending_sizes (old_sizes
);
7639 if (bt
== FFEINFO_basictypeCHARACTER
)
7640 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7641 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7643 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7645 if (type
== error_mark_node
)
7648 dim
= ffebld_head (dl
);
7649 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7650 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7651 low
= ffecom_integer_one_node
;
7653 low
= ffecom_expr (ffebld_left (dim
));
7654 assert (ffebld_right (dim
) != NULL
);
7655 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7656 || ffecom_doing_entry_
)
7658 /* Used to just do high=low. But for ffecom_tree_
7659 canonize_ref_, it probably is important to correctly
7660 assess the size. E.g. given COMPLEX C(*),CFUNC and
7661 C(2)=CFUNC(C), overlap can happen, while it can't
7662 for, say, C(1)=CFUNC(C(2)). */
7663 /* Even more recently used to set to INT_MAX, but that
7664 broke when some overflow checking went into the back
7665 end. Now we just leave the upper bound unspecified. */
7669 high
= ffecom_expr (ffebld_right (dim
));
7671 /* Determine whether array is conditionally adjustable,
7672 to decide whether back-end magic is needed.
7674 Normally the front end uses the back-end function
7675 variable_size to wrap SAVE_EXPR's around expressions
7676 affecting the size/shape of an array so that the
7677 size/shape info doesn't change during execution
7678 of the compiled code even though variables and
7679 functions referenced in those expressions might.
7681 variable_size also makes sure those saved expressions
7682 get evaluated immediately upon entry to the
7683 compiled procedure -- the front end normally doesn't
7684 have to worry about that.
7686 However, there is a problem with this that affects
7687 g77's implementation of entry points, and that is
7688 that it is _not_ true that each invocation of the
7689 compiled procedure is permitted to evaluate
7690 array size/shape info -- because it is possible
7691 that, for some invocations, that info is invalid (in
7692 which case it is "promised" -- i.e. a violation of
7693 the Fortran standard -- that the compiled code
7694 won't reference the array or its size/shape
7695 during that particular invocation).
7697 To phrase this in C terms, consider this gcc function:
7699 void foo (int *n, float (*a)[*n])
7701 // a is "pointer to array ...", fyi.
7704 Suppose that, for some invocations, it is permitted
7705 for a caller of foo to do this:
7709 Now the _written_ code for foo can take such a call
7710 into account by either testing explicitly for whether
7711 (a == NULL) || (n == NULL) -- presumably it is
7712 not permitted to reference *a in various fashions
7713 if (n == NULL) I suppose -- or it can avoid it by
7714 looking at other info (other arguments, static/global
7717 However, this won't work in gcc 2.5.8 because it'll
7718 automatically emit the code to save the "*n"
7719 expression, which'll yield a NULL dereference for
7720 the "foo (NULL, NULL)" call, something the code
7721 for foo cannot prevent.
7723 g77 definitely needs to avoid executing such
7724 code anytime the pointer to the adjustable array
7725 is NULL, because even if its bounds expressions
7726 don't have any references to possible "absent"
7727 variables like "*n" -- say all variable references
7728 are to COMMON variables, i.e. global (though in C,
7729 local static could actually make sense) -- the
7730 expressions could yield other run-time problems
7731 for allowably "dead" values in those variables.
7733 For example, let's consider a more complicated
7739 void foo (float (*a)[i/j])
7744 The above is (essentially) quite valid for Fortran
7745 but, again, for a call like "foo (NULL);", it is
7746 permitted for i and j to be undefined when the
7747 call is made. If j happened to be zero, for
7748 example, emitting the code to evaluate "i/j"
7749 could result in a run-time error.
7751 Offhand, though I don't have my F77 or F90
7752 standards handy, it might even be valid for a
7753 bounds expression to contain a function reference,
7754 in which case I doubt it is permitted for an
7755 implementation to invoke that function in the
7756 Fortran case involved here (invocation of an
7757 alternate ENTRY point that doesn't have the adjustable
7758 array as one of its arguments).
7760 So, the code that the compiler would normally emit
7761 to preevaluate the size/shape info for an
7762 adjustable array _must not_ be executed at run time
7763 in certain cases. Specifically, for Fortran,
7764 the case is when the pointer to the adjustable
7765 array == NULL. (For gnu-ish C, it might be nice
7766 for the source code itself to specify an expression
7767 that, if TRUE, inhibits execution of the code. Or
7768 reverse the sense for elegance.)
7770 (Note that g77 could use a different test than NULL,
7771 actually, since it happens to always pass an
7772 integer to the called function that specifies which
7773 entry point is being invoked. Hmm, this might
7774 solve the next problem.)
7776 One way a user could, I suppose, write "foo" so
7777 it works is to insert COND_EXPR's for the
7778 size/shape info so the dangerous stuff isn't
7779 actually done, as in:
7781 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7786 The next problem is that the front end needs to
7787 be able to tell the back end about the array's
7788 decl _before_ it tells it about the conditional
7789 expression to inhibit evaluation of size/shape info,
7792 To solve this, the front end needs to be able
7793 to give the back end the expression to inhibit
7794 generation of the preevaluation code _after_
7795 it makes the decl for the adjustable array.
7797 Until then, the above example using the COND_EXPR
7798 doesn't pass muster with gcc because the "(a == NULL)"
7799 part has a reference to "a", which is still
7800 undefined at that point.
7802 g77 will therefore use a different mechanism in the
7806 && ((TREE_CODE (low
) != INTEGER_CST
)
7807 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7810 #if 0 /* Old approach -- see below. */
7811 if (TREE_CODE (low
) != INTEGER_CST
)
7812 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7813 ffecom_adjarray_passed_ (s
),
7815 ffecom_integer_zero_node
);
7817 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7818 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7819 ffecom_adjarray_passed_ (s
),
7821 ffecom_integer_zero_node
);
7824 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7825 probably. Fixes 950302-1.f. */
7827 if (TREE_CODE (low
) != INTEGER_CST
)
7828 low
= variable_size (low
);
7830 /* ~~~Similarly, this fixes dumb0.f. The C front end
7831 does this, which is why dumb0.c would work. */
7833 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7834 high
= variable_size (high
);
7839 build_range_type (ffecom_integer_type_node
,
7841 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7844 if (type
== error_mark_node
)
7846 t
= error_mark_node
;
7850 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7851 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7853 type
= build_pointer_type (type
);
7857 t
= build_decl (PARM_DECL
, t
, type
);
7858 DECL_ARTIFICIAL (t
) = 1;
7860 /* If this arg is present in every entry point's list of
7861 dummy args, then we're done. */
7863 if (ffesymbol_numentries (s
)
7864 == (ffecom_num_entrypoints_
+ 1))
7869 /* If variable_size in stor-layout has been called during
7870 the above, then get_pending_sizes should have the
7871 yet-to-be-evaluated saved expressions pending.
7872 Make the whole lot of them get emitted, conditionally
7873 on whether the array decl ("t" above) is not NULL. */
7876 tree sizes
= get_pending_sizes ();
7881 tem
= TREE_CHAIN (tem
))
7883 tree temv
= TREE_VALUE (tem
);
7889 = ffecom_2 (COMPOUND_EXPR
,
7898 = ffecom_3 (COND_EXPR
,
7905 convert (TREE_TYPE (sizes
),
7906 integer_zero_node
));
7907 sizes
= ffecom_save_tree (sizes
);
7910 = tree_cons (NULL_TREE
, sizes
, tem
);
7914 put_pending_sizes (sizes
);
7920 && (ffesymbol_numentries (s
)
7921 != ffecom_num_entrypoints_
+ 1))
7923 = ffecom_2 (NE_EXPR
, integer_type_node
,
7929 && (ffesymbol_numentries (s
)
7930 != ffecom_num_entrypoints_
+ 1))
7932 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
7933 ffebad_here (0, ffesymbol_where_line (s
),
7934 ffesymbol_where_column (s
));
7935 ffebad_string (ffesymbol_text (s
));
7944 case FFEINFO_whereCOMMON
:
7949 ffestorag st
= ffesymbol_storage (s
);
7952 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
7953 if (st
!= NULL
) /* Else not laid out. */
7955 ffecom_transform_common_ (cs
);
7956 st
= ffesymbol_storage (s
);
7959 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7961 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
7963 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
7966 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
7968 if ((ct
== NULL_TREE
)
7970 || (type
== error_mark_node
))
7971 t
= error_mark_node
;
7974 ffetargetOffset offset
;
7977 cst
= ffestorag_parent (st
);
7978 assert (cst
== ffesymbol_storage (cs
));
7980 offset
= ffestorag_modulo (cst
)
7981 + ffestorag_offset (st
)
7982 - ffestorag_offset (cst
);
7984 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
7986 /* (t_type *) (((char *) &ct) + offset) */
7988 t
= convert (string_type_node
, /* (char *) */
7989 ffecom_1 (ADDR_EXPR
,
7990 build_pointer_type (TREE_TYPE (ct
)),
7992 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7994 build_int_2 (offset
, 0));
7995 t
= convert (build_pointer_type (type
),
7997 TREE_CONSTANT (t
) = 1;
8004 case FFEINFO_whereIMMEDIATE
:
8005 case FFEINFO_whereGLOBAL
:
8006 case FFEINFO_whereFLEETING
:
8007 case FFEINFO_whereFLEETING_CADDR
:
8008 case FFEINFO_whereFLEETING_IADDR
:
8009 case FFEINFO_whereINTRINSIC
:
8010 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8012 assert ("ENTITY where unheard of" == NULL
);
8014 case FFEINFO_whereANY
:
8015 t
= error_mark_node
;
8020 case FFEINFO_kindFUNCTION
:
8021 switch (ffeinfo_where (ffesymbol_info (s
)))
8023 case FFEINFO_whereLOCAL
: /* Me. */
8024 assert (!ffecom_transform_only_dummies_
);
8025 t
= current_function_decl
;
8028 case FFEINFO_whereGLOBAL
:
8029 assert (!ffecom_transform_only_dummies_
);
8031 if (((g
= ffesymbol_global (s
)) != NULL
)
8032 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8033 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8034 && (ffeglobal_hook (g
) != NULL_TREE
)
8035 && ffe_is_globals ())
8037 t
= ffeglobal_hook (g
);
8041 if (ffesymbol_is_f2c (s
)
8042 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8043 t
= ffecom_tree_fun_type
[bt
][kt
];
8045 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8047 t
= build_decl (FUNCTION_DECL
,
8048 ffecom_get_external_identifier_ (s
),
8050 DECL_EXTERNAL (t
) = 1;
8051 TREE_PUBLIC (t
) = 1;
8053 t
= start_decl (t
, FALSE
);
8054 finish_decl (t
, NULL_TREE
, FALSE
);
8057 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8058 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8059 ffeglobal_set_hook (g
, t
);
8061 ffecom_save_tree_forever (t
);
8065 case FFEINFO_whereDUMMY
:
8066 assert (ffecom_transform_only_dummies_
);
8068 if (ffesymbol_is_f2c (s
)
8069 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8070 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8072 t
= build_pointer_type
8073 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8075 t
= build_decl (PARM_DECL
,
8076 ffecom_get_identifier_ (ffesymbol_text (s
)),
8078 DECL_ARTIFICIAL (t
) = 1;
8082 case FFEINFO_whereCONSTANT
: /* Statement function. */
8083 assert (!ffecom_transform_only_dummies_
);
8084 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8087 case FFEINFO_whereINTRINSIC
:
8088 assert (!ffecom_transform_only_dummies_
);
8089 break; /* Let actual references generate their
8093 assert ("FUNCTION where unheard of" == NULL
);
8095 case FFEINFO_whereANY
:
8096 t
= error_mark_node
;
8101 case FFEINFO_kindSUBROUTINE
:
8102 switch (ffeinfo_where (ffesymbol_info (s
)))
8104 case FFEINFO_whereLOCAL
: /* Me. */
8105 assert (!ffecom_transform_only_dummies_
);
8106 t
= current_function_decl
;
8109 case FFEINFO_whereGLOBAL
:
8110 assert (!ffecom_transform_only_dummies_
);
8112 if (((g
= ffesymbol_global (s
)) != NULL
)
8113 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8114 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8115 && (ffeglobal_hook (g
) != NULL_TREE
)
8116 && ffe_is_globals ())
8118 t
= ffeglobal_hook (g
);
8122 t
= build_decl (FUNCTION_DECL
,
8123 ffecom_get_external_identifier_ (s
),
8124 ffecom_tree_subr_type
);
8125 DECL_EXTERNAL (t
) = 1;
8126 TREE_PUBLIC (t
) = 1;
8128 t
= start_decl (t
, FALSE
);
8129 finish_decl (t
, NULL_TREE
, FALSE
);
8132 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8133 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8134 ffeglobal_set_hook (g
, t
);
8136 ffecom_save_tree_forever (t
);
8140 case FFEINFO_whereDUMMY
:
8141 assert (ffecom_transform_only_dummies_
);
8143 t
= build_decl (PARM_DECL
,
8144 ffecom_get_identifier_ (ffesymbol_text (s
)),
8145 ffecom_tree_ptr_to_subr_type
);
8146 DECL_ARTIFICIAL (t
) = 1;
8150 case FFEINFO_whereINTRINSIC
:
8151 assert (!ffecom_transform_only_dummies_
);
8152 break; /* Let actual references generate their
8156 assert ("SUBROUTINE where unheard of" == NULL
);
8158 case FFEINFO_whereANY
:
8159 t
= error_mark_node
;
8164 case FFEINFO_kindPROGRAM
:
8165 switch (ffeinfo_where (ffesymbol_info (s
)))
8167 case FFEINFO_whereLOCAL
: /* Me. */
8168 assert (!ffecom_transform_only_dummies_
);
8169 t
= current_function_decl
;
8172 case FFEINFO_whereCOMMON
:
8173 case FFEINFO_whereDUMMY
:
8174 case FFEINFO_whereGLOBAL
:
8175 case FFEINFO_whereRESULT
:
8176 case FFEINFO_whereFLEETING
:
8177 case FFEINFO_whereFLEETING_CADDR
:
8178 case FFEINFO_whereFLEETING_IADDR
:
8179 case FFEINFO_whereIMMEDIATE
:
8180 case FFEINFO_whereINTRINSIC
:
8181 case FFEINFO_whereCONSTANT
:
8182 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8184 assert ("PROGRAM where unheard of" == NULL
);
8186 case FFEINFO_whereANY
:
8187 t
= error_mark_node
;
8192 case FFEINFO_kindBLOCKDATA
:
8193 switch (ffeinfo_where (ffesymbol_info (s
)))
8195 case FFEINFO_whereLOCAL
: /* Me. */
8196 assert (!ffecom_transform_only_dummies_
);
8197 t
= current_function_decl
;
8200 case FFEINFO_whereGLOBAL
:
8201 assert (!ffecom_transform_only_dummies_
);
8203 t
= build_decl (FUNCTION_DECL
,
8204 ffecom_get_external_identifier_ (s
),
8205 ffecom_tree_blockdata_type
);
8206 DECL_EXTERNAL (t
) = 1;
8207 TREE_PUBLIC (t
) = 1;
8209 t
= start_decl (t
, FALSE
);
8210 finish_decl (t
, NULL_TREE
, FALSE
);
8212 ffecom_save_tree_forever (t
);
8216 case FFEINFO_whereCOMMON
:
8217 case FFEINFO_whereDUMMY
:
8218 case FFEINFO_whereRESULT
:
8219 case FFEINFO_whereFLEETING
:
8220 case FFEINFO_whereFLEETING_CADDR
:
8221 case FFEINFO_whereFLEETING_IADDR
:
8222 case FFEINFO_whereIMMEDIATE
:
8223 case FFEINFO_whereINTRINSIC
:
8224 case FFEINFO_whereCONSTANT
:
8225 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8227 assert ("BLOCKDATA where unheard of" == NULL
);
8229 case FFEINFO_whereANY
:
8230 t
= error_mark_node
;
8235 case FFEINFO_kindCOMMON
:
8236 switch (ffeinfo_where (ffesymbol_info (s
)))
8238 case FFEINFO_whereLOCAL
:
8239 assert (!ffecom_transform_only_dummies_
);
8240 ffecom_transform_common_ (s
);
8243 case FFEINFO_whereNONE
:
8244 case FFEINFO_whereCOMMON
:
8245 case FFEINFO_whereDUMMY
:
8246 case FFEINFO_whereGLOBAL
:
8247 case FFEINFO_whereRESULT
:
8248 case FFEINFO_whereFLEETING
:
8249 case FFEINFO_whereFLEETING_CADDR
:
8250 case FFEINFO_whereFLEETING_IADDR
:
8251 case FFEINFO_whereIMMEDIATE
:
8252 case FFEINFO_whereINTRINSIC
:
8253 case FFEINFO_whereCONSTANT
:
8254 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8256 assert ("COMMON where unheard of" == NULL
);
8258 case FFEINFO_whereANY
:
8259 t
= error_mark_node
;
8264 case FFEINFO_kindCONSTRUCT
:
8265 switch (ffeinfo_where (ffesymbol_info (s
)))
8267 case FFEINFO_whereLOCAL
:
8268 assert (!ffecom_transform_only_dummies_
);
8271 case FFEINFO_whereNONE
:
8272 case FFEINFO_whereCOMMON
:
8273 case FFEINFO_whereDUMMY
:
8274 case FFEINFO_whereGLOBAL
:
8275 case FFEINFO_whereRESULT
:
8276 case FFEINFO_whereFLEETING
:
8277 case FFEINFO_whereFLEETING_CADDR
:
8278 case FFEINFO_whereFLEETING_IADDR
:
8279 case FFEINFO_whereIMMEDIATE
:
8280 case FFEINFO_whereINTRINSIC
:
8281 case FFEINFO_whereCONSTANT
:
8282 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8284 assert ("CONSTRUCT where unheard of" == NULL
);
8286 case FFEINFO_whereANY
:
8287 t
= error_mark_node
;
8292 case FFEINFO_kindNAMELIST
:
8293 switch (ffeinfo_where (ffesymbol_info (s
)))
8295 case FFEINFO_whereLOCAL
:
8296 assert (!ffecom_transform_only_dummies_
);
8297 t
= ffecom_transform_namelist_ (s
);
8300 case FFEINFO_whereNONE
:
8301 case FFEINFO_whereCOMMON
:
8302 case FFEINFO_whereDUMMY
:
8303 case FFEINFO_whereGLOBAL
:
8304 case FFEINFO_whereRESULT
:
8305 case FFEINFO_whereFLEETING
:
8306 case FFEINFO_whereFLEETING_CADDR
:
8307 case FFEINFO_whereFLEETING_IADDR
:
8308 case FFEINFO_whereIMMEDIATE
:
8309 case FFEINFO_whereINTRINSIC
:
8310 case FFEINFO_whereCONSTANT
:
8311 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8313 assert ("NAMELIST where unheard of" == NULL
);
8315 case FFEINFO_whereANY
:
8316 t
= error_mark_node
;
8322 assert ("kind unheard of" == NULL
);
8324 case FFEINFO_kindANY
:
8325 t
= error_mark_node
;
8329 ffesymbol_hook (s
).decl_tree
= t
;
8330 ffesymbol_hook (s
).length_tree
= tlen
;
8331 ffesymbol_hook (s
).addr
= addr
;
8333 lineno
= old_lineno
;
8334 input_filename
= old_input_filename
;
8339 /* Transform into ASSIGNable symbol.
8341 Symbol has already been transformed, but for whatever reason, the
8342 resulting decl_tree has been deemed not usable for an ASSIGN target.
8343 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8344 another local symbol of type void * and stuff that in the assign_tree
8345 argument. The F77/F90 standards allow this implementation. */
8348 ffecom_sym_transform_assign_ (ffesymbol s
)
8350 tree t
; /* Transformed thingy. */
8351 int old_lineno
= lineno
;
8352 const char *old_input_filename
= input_filename
;
8354 if (ffesymbol_sfdummyparent (s
) == NULL
)
8356 input_filename
= ffesymbol_where_filename (s
);
8357 lineno
= ffesymbol_where_filelinenum (s
);
8361 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8363 input_filename
= ffesymbol_where_filename (sf
);
8364 lineno
= ffesymbol_where_filelinenum (sf
);
8367 assert (!ffecom_transform_only_dummies_
);
8369 t
= build_decl (VAR_DECL
,
8370 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8371 ffesymbol_text (s
)),
8372 TREE_TYPE (null_pointer_node
));
8374 switch (ffesymbol_where (s
))
8376 case FFEINFO_whereLOCAL
:
8377 /* Unlike for regular vars, SAVE status is easy to determine for
8378 ASSIGNed vars, since there's no initialization, there's no
8379 effective storage association (so "SAVE J" does not apply to
8380 K even given "EQUIVALENCE (J,K)"), there's no size issue
8381 to worry about, etc. */
8382 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8383 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8384 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8385 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8387 TREE_STATIC (t
) = 0; /* No need to make static. */
8390 case FFEINFO_whereCOMMON
:
8391 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8394 case FFEINFO_whereDUMMY
:
8395 /* Note that twinning a DUMMY means the caller won't see
8396 the ASSIGNed value. But both F77 and F90 allow implementations
8397 to do this, i.e. disallow Fortran code that would try and
8398 take advantage of actually putting a label into a variable
8399 via a dummy argument (or any other storage association, for
8401 TREE_STATIC (t
) = 0;
8405 TREE_STATIC (t
) = 0;
8409 t
= start_decl (t
, FALSE
);
8410 finish_decl (t
, NULL_TREE
, FALSE
);
8412 ffesymbol_hook (s
).assign_tree
= t
;
8414 lineno
= old_lineno
;
8415 input_filename
= old_input_filename
;
8420 /* Implement COMMON area in back end.
8422 Because COMMON-based variables can be referenced in the dimension
8423 expressions of dummy (adjustable) arrays, and because dummies
8424 (in the gcc back end) need to be put in the outer binding level
8425 of a function (which has two binding levels, the outer holding
8426 the dummies and the inner holding the other vars), special care
8427 must be taken to handle COMMON areas.
8429 The current strategy is basically to always tell the back end about
8430 the COMMON area as a top-level external reference to just a block
8431 of storage of the master type of that area (e.g. integer, real,
8432 character, whatever -- not a structure). As a distinct action,
8433 if initial values are provided, tell the back end about the area
8434 as a top-level non-external (initialized) area and remember not to
8435 allow further initialization or expansion of the area. Meanwhile,
8436 if no initialization happens at all, tell the back end about
8437 the largest size we've seen declared so the space does get reserved.
8438 (This function doesn't handle all that stuff, but it does some
8439 of the important things.)
8441 Meanwhile, for COMMON variables themselves, just keep creating
8442 references like *((float *) (&common_area + offset)) each time
8443 we reference the variable. In other words, don't make a VAR_DECL
8444 or any kind of component reference (like we used to do before 0.4),
8445 though we might do that as well just for debugging purposes (and
8446 stuff the rtl with the appropriate offset expression). */
8449 ffecom_transform_common_ (ffesymbol s
)
8451 ffestorag st
= ffesymbol_storage (s
);
8452 ffeglobal g
= ffesymbol_global (s
);
8457 bool is_init
= ffestorag_is_init (st
);
8459 assert (st
!= NULL
);
8462 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8465 /* First update the size of the area in global terms. */
8467 ffeglobal_size_common (s
, ffestorag_size (st
));
8469 if (!ffeglobal_common_init (g
))
8470 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8472 cbt
= ffeglobal_hook (g
);
8474 /* If we already have declared this common block for a previous program
8475 unit, and either we already initialized it or we don't have new
8476 initialization for it, just return what we have without changing it. */
8478 if ((cbt
!= NULL_TREE
)
8480 || !DECL_EXTERNAL (cbt
)))
8482 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8486 /* Process inits. */
8490 if (ffestorag_init (st
) != NULL
)
8494 /* Set the padding for the expression, so ffecom_expr
8495 knows to insert that many zeros. */
8496 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8498 case FFEBLD_opCONTER
:
8499 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8502 case FFEBLD_opARRTER
:
8503 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8506 case FFEBLD_opACCTER
:
8507 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8511 assert ("bad op for cmn init (pad)" == NULL
);
8515 init
= ffecom_expr (sexp
);
8516 if (init
== error_mark_node
)
8517 { /* Hopefully the back end complained! */
8519 if (cbt
!= NULL_TREE
)
8524 init
= error_mark_node
;
8529 /* cbtype must be permanently allocated! */
8531 /* Allocate the MAX of the areas so far, seen filewide. */
8532 high
= build_int_2 ((ffeglobal_common_size (g
)
8533 + ffeglobal_common_pad (g
)) - 1, 0);
8534 TREE_TYPE (high
) = ffecom_integer_type_node
;
8537 cbtype
= build_array_type (char_type_node
,
8538 build_range_type (integer_type_node
,
8542 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8544 if (cbt
== NULL_TREE
)
8547 = build_decl (VAR_DECL
,
8548 ffecom_get_external_identifier_ (s
),
8550 TREE_STATIC (cbt
) = 1;
8551 TREE_PUBLIC (cbt
) = 1;
8556 TREE_TYPE (cbt
) = cbtype
;
8558 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8559 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8561 cbt
= start_decl (cbt
, TRUE
);
8562 if (ffeglobal_hook (g
) != NULL
)
8563 assert (cbt
== ffeglobal_hook (g
));
8565 assert (!init
|| !DECL_EXTERNAL (cbt
));
8567 /* Make sure that any type can live in COMMON and be referenced
8568 without getting a bus error. We could pick the most restrictive
8569 alignment of all entities actually placed in the COMMON, but
8570 this seems easy enough. */
8572 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8573 DECL_USER_ALIGN (cbt
) = 0;
8575 if (is_init
&& (ffestorag_init (st
) == NULL
))
8576 init
= ffecom_init_zero_ (cbt
);
8578 finish_decl (cbt
, init
, TRUE
);
8581 ffestorag_set_init (st
, ffebld_new_any ());
8585 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8586 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8587 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8588 (ffeglobal_common_size (g
)
8589 + ffeglobal_common_pad (g
))));
8592 ffeglobal_set_hook (g
, cbt
);
8594 ffestorag_set_hook (st
, cbt
);
8596 ffecom_save_tree_forever (cbt
);
8599 /* Make master area for local EQUIVALENCE. */
8602 ffecom_transform_equiv_ (ffestorag eqst
)
8608 bool is_init
= ffestorag_is_init (eqst
);
8610 assert (eqst
!= NULL
);
8612 eqt
= ffestorag_hook (eqst
);
8614 if (eqt
!= NULL_TREE
)
8617 /* Process inits. */
8621 if (ffestorag_init (eqst
) != NULL
)
8625 /* Set the padding for the expression, so ffecom_expr
8626 knows to insert that many zeros. */
8627 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8629 case FFEBLD_opCONTER
:
8630 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8633 case FFEBLD_opARRTER
:
8634 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8637 case FFEBLD_opACCTER
:
8638 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8642 assert ("bad op for eqv init (pad)" == NULL
);
8646 init
= ffecom_expr (sexp
);
8647 if (init
== error_mark_node
)
8648 init
= NULL_TREE
; /* Hopefully the back end complained! */
8651 init
= error_mark_node
;
8653 else if (ffe_is_init_local_zero ())
8654 init
= error_mark_node
;
8658 ffecom_member_namelisted_
= FALSE
;
8659 ffestorag_drive (ffestorag_list_equivs (eqst
),
8660 &ffecom_member_phase1_
,
8663 high
= build_int_2 ((ffestorag_size (eqst
)
8664 + ffestorag_modulo (eqst
)) - 1, 0);
8665 TREE_TYPE (high
) = ffecom_integer_type_node
;
8667 eqtype
= build_array_type (char_type_node
,
8668 build_range_type (ffecom_integer_type_node
,
8669 ffecom_integer_zero_node
,
8672 eqt
= build_decl (VAR_DECL
,
8673 ffecom_get_invented_identifier ("__g77_equiv_%s",
8675 (ffestorag_symbol (eqst
))),
8677 DECL_EXTERNAL (eqt
) = 0;
8679 || ffecom_member_namelisted_
8680 #ifdef FFECOM_sizeMAXSTACKITEM
8681 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8683 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8684 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8685 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8686 TREE_STATIC (eqt
) = 1;
8688 TREE_STATIC (eqt
) = 0;
8689 TREE_PUBLIC (eqt
) = 0;
8690 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8691 DECL_CONTEXT (eqt
) = current_function_decl
;
8693 DECL_INITIAL (eqt
) = error_mark_node
;
8695 DECL_INITIAL (eqt
) = NULL_TREE
;
8697 eqt
= start_decl (eqt
, FALSE
);
8699 /* Make sure that any type can live in EQUIVALENCE and be referenced
8700 without getting a bus error. We could pick the most restrictive
8701 alignment of all entities actually placed in the EQUIVALENCE, but
8702 this seems easy enough. */
8704 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8705 DECL_USER_ALIGN (eqt
) = 0;
8707 if ((!is_init
&& ffe_is_init_local_zero ())
8708 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8709 init
= ffecom_init_zero_ (eqt
);
8711 finish_decl (eqt
, init
, FALSE
);
8714 ffestorag_set_init (eqst
, ffebld_new_any ());
8717 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8718 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8719 (ffestorag_size (eqst
)
8720 + ffestorag_modulo (eqst
))));
8723 ffestorag_set_hook (eqst
, eqt
);
8725 ffestorag_drive (ffestorag_list_equivs (eqst
),
8726 &ffecom_member_phase2_
,
8730 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8733 ffecom_transform_namelist_ (ffesymbol s
)
8736 tree nmltype
= ffecom_type_namelist_ ();
8744 static int mynumber
= 0;
8746 nmlt
= build_decl (VAR_DECL
,
8747 ffecom_get_invented_identifier ("__g77_namelist_%d",
8750 TREE_STATIC (nmlt
) = 1;
8751 DECL_INITIAL (nmlt
) = error_mark_node
;
8753 nmlt
= start_decl (nmlt
, FALSE
);
8755 /* Process inits. */
8757 i
= strlen (ffesymbol_text (s
));
8759 high
= build_int_2 (i
, 0);
8760 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8762 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8763 ffesymbol_text (s
));
8764 TREE_TYPE (nameinit
)
8765 = build_type_variant
8768 build_range_type (ffecom_f2c_ftnlen_type_node
,
8769 ffecom_f2c_ftnlen_one_node
,
8772 TREE_CONSTANT (nameinit
) = 1;
8773 TREE_STATIC (nameinit
) = 1;
8774 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8777 varsinit
= ffecom_vardesc_array_ (s
);
8778 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8780 TREE_CONSTANT (varsinit
) = 1;
8781 TREE_STATIC (varsinit
) = 1;
8786 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8789 nvarsinit
= build_int_2 (i
, 0);
8790 TREE_TYPE (nvarsinit
) = integer_type_node
;
8791 TREE_CONSTANT (nvarsinit
) = 1;
8792 TREE_STATIC (nvarsinit
) = 1;
8794 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8795 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8797 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8798 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8800 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8801 TREE_CONSTANT (nmlinits
) = 1;
8802 TREE_STATIC (nmlinits
) = 1;
8804 finish_decl (nmlt
, nmlinits
, FALSE
);
8806 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8811 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8812 analyzed on the assumption it is calculating a pointer to be
8813 indirected through. It must return the proper decl and offset,
8814 taking into account different units of measurements for offsets. */
8817 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8820 switch (TREE_CODE (t
))
8824 case NON_LVALUE_EXPR
:
8825 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8829 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8830 if ((*decl
== NULL_TREE
)
8831 || (*decl
== error_mark_node
))
8834 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8836 /* An offset into COMMON. */
8837 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8838 *offset
, TREE_OPERAND (t
, 1)));
8839 /* Convert offset (presumably in bytes) into canonical units
8840 (presumably bits). */
8841 *offset
= size_binop (MULT_EXPR
,
8842 convert (bitsizetype
, *offset
),
8843 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8846 /* Not a COMMON reference, so an unrecognized pattern. */
8847 *decl
= error_mark_node
;
8852 *offset
= bitsize_zero_node
;
8856 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8858 /* A reference to COMMON. */
8859 *decl
= TREE_OPERAND (t
, 0);
8860 *offset
= bitsize_zero_node
;
8865 /* Not a COMMON reference, so an unrecognized pattern. */
8866 *decl
= error_mark_node
;
8871 /* Given a tree that is possibly intended for use as an lvalue, return
8872 information representing a canonical view of that tree as a decl, an
8873 offset into that decl, and a size for the lvalue.
8875 If there's no applicable decl, NULL_TREE is returned for the decl,
8876 and the other fields are left undefined.
8878 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8879 is returned for the decl, and the other fields are left undefined.
8881 Otherwise, the decl returned currently is either a VAR_DECL or a
8884 The offset returned is always valid, but of course not necessarily
8885 a constant, and not necessarily converted into the appropriate
8886 type, leaving that up to the caller (so as to avoid that overhead
8887 if the decls being looked at are different anyway).
8889 If the size cannot be determined (e.g. an adjustable array),
8890 an ERROR_MARK node is returned for the size. Otherwise, the
8891 size returned is valid, not necessarily a constant, and not
8892 necessarily converted into the appropriate type as with the
8895 Note that the offset and size expressions are expressed in the
8896 base storage units (usually bits) rather than in the units of
8897 the type of the decl, because two decls with different types
8898 might overlap but with apparently non-overlapping array offsets,
8899 whereas converting the array offsets to consistant offsets will
8900 reveal the overlap. */
8903 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
8906 /* The default path is to report a nonexistant decl. */
8912 switch (TREE_CODE (t
))
8915 case IDENTIFIER_NODE
:
8924 case TRUNC_DIV_EXPR
:
8926 case FLOOR_DIV_EXPR
:
8927 case ROUND_DIV_EXPR
:
8928 case TRUNC_MOD_EXPR
:
8930 case FLOOR_MOD_EXPR
:
8931 case ROUND_MOD_EXPR
:
8933 case EXACT_DIV_EXPR
:
8934 case FIX_TRUNC_EXPR
:
8936 case FIX_FLOOR_EXPR
:
8937 case FIX_ROUND_EXPR
:
8951 case BIT_ANDTC_EXPR
:
8953 case TRUTH_ANDIF_EXPR
:
8954 case TRUTH_ORIF_EXPR
:
8955 case TRUTH_AND_EXPR
:
8957 case TRUTH_XOR_EXPR
:
8958 case TRUTH_NOT_EXPR
:
8978 *offset
= bitsize_zero_node
;
8979 *size
= TYPE_SIZE (TREE_TYPE (t
));
8984 tree array
= TREE_OPERAND (t
, 0);
8985 tree element
= TREE_OPERAND (t
, 1);
8988 if ((array
== NULL_TREE
)
8989 || (element
== NULL_TREE
))
8991 *decl
= error_mark_node
;
8995 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
8997 if ((*decl
== NULL_TREE
)
8998 || (*decl
== error_mark_node
))
9001 /* Calculate ((element - base) * NBBY) + init_offset. */
9002 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
9004 TYPE_MIN_VALUE (TYPE_DOMAIN
9005 (TREE_TYPE (array
)))));
9007 *offset
= size_binop (MULT_EXPR
,
9008 convert (bitsizetype
, *offset
),
9009 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
9011 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
9013 *size
= TYPE_SIZE (TREE_TYPE (t
));
9019 /* Most of this code is to handle references to COMMON. And so
9020 far that is useful only for calling library functions, since
9021 external (user) functions might reference common areas. But
9022 even calling an external function, it's worthwhile to decode
9023 COMMON references because if not storing into COMMON, we don't
9024 want COMMON-based arguments to gratuitously force use of a
9027 *size
= TYPE_SIZE (TREE_TYPE (t
));
9029 ffecom_tree_canonize_ptr_ (decl
, offset
,
9030 TREE_OPERAND (t
, 0));
9037 case NON_LVALUE_EXPR
:
9040 case COND_EXPR
: /* More cases than we can handle. */
9042 case REFERENCE_EXPR
:
9043 case PREDECREMENT_EXPR
:
9044 case PREINCREMENT_EXPR
:
9045 case POSTDECREMENT_EXPR
:
9046 case POSTINCREMENT_EXPR
:
9049 *decl
= error_mark_node
;
9054 /* Do divide operation appropriate to type of operands. */
9057 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9058 tree dest_tree
, ffebld dest
, bool *dest_used
,
9061 if ((left
== error_mark_node
)
9062 || (right
== error_mark_node
))
9063 return error_mark_node
;
9065 switch (TREE_CODE (tree_type
))
9068 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9073 if (! optimize_size
)
9074 return ffecom_2 (RDIV_EXPR
, tree_type
,
9080 if (TREE_TYPE (tree_type
)
9081 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9082 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9084 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9086 left
= ffecom_1 (ADDR_EXPR
,
9087 build_pointer_type (TREE_TYPE (left
)),
9089 left
= build_tree_list (NULL_TREE
, left
);
9090 right
= ffecom_1 (ADDR_EXPR
,
9091 build_pointer_type (TREE_TYPE (right
)),
9093 right
= build_tree_list (NULL_TREE
, right
);
9094 TREE_CHAIN (left
) = right
;
9096 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9097 ffecom_gfrt_kindtype (ix
),
9098 ffe_is_f2c_library (),
9101 dest_tree
, dest
, dest_used
,
9102 NULL_TREE
, TRUE
, hook
);
9110 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9111 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9112 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9114 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9116 left
= ffecom_1 (ADDR_EXPR
,
9117 build_pointer_type (TREE_TYPE (left
)),
9119 left
= build_tree_list (NULL_TREE
, left
);
9120 right
= ffecom_1 (ADDR_EXPR
,
9121 build_pointer_type (TREE_TYPE (right
)),
9123 right
= build_tree_list (NULL_TREE
, right
);
9124 TREE_CHAIN (left
) = right
;
9126 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9127 ffecom_gfrt_kindtype (ix
),
9128 ffe_is_f2c_library (),
9131 dest_tree
, dest
, dest_used
,
9132 NULL_TREE
, TRUE
, hook
);
9137 return ffecom_2 (RDIV_EXPR
, tree_type
,
9143 /* Build type info for non-dummy variable. */
9146 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9155 type
= ffecom_tree_type
[bt
][kt
];
9156 if (bt
== FFEINFO_basictypeCHARACTER
)
9158 hight
= build_int_2 (ffesymbol_size (s
), 0);
9159 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9164 build_range_type (ffecom_f2c_ftnlen_type_node
,
9165 ffecom_f2c_ftnlen_one_node
,
9167 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9170 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9172 if (type
== error_mark_node
)
9175 dim
= ffebld_head (dl
);
9176 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9178 if (ffebld_left (dim
) == NULL
)
9179 lowt
= integer_one_node
;
9181 lowt
= ffecom_expr (ffebld_left (dim
));
9183 if (TREE_CODE (lowt
) != INTEGER_CST
)
9184 lowt
= variable_size (lowt
);
9186 assert (ffebld_right (dim
) != NULL
);
9187 hight
= ffecom_expr (ffebld_right (dim
));
9189 if (TREE_CODE (hight
) != INTEGER_CST
)
9190 hight
= variable_size (hight
);
9192 type
= build_array_type (type
,
9193 build_range_type (ffecom_integer_type_node
,
9195 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9201 /* Build Namelist type. */
9204 ffecom_type_namelist_ ()
9206 static tree type
= NULL_TREE
;
9208 if (type
== NULL_TREE
)
9210 static tree namefield
, varsfield
, nvarsfield
;
9213 vardesctype
= ffecom_type_vardesc_ ();
9215 type
= make_node (RECORD_TYPE
);
9217 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9219 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9221 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9222 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9225 TYPE_FIELDS (type
) = namefield
;
9228 ggc_add_tree_root (&type
, 1);
9234 /* Build Vardesc type. */
9237 ffecom_type_vardesc_ ()
9239 static tree type
= NULL_TREE
;
9240 static tree namefield
, addrfield
, dimsfield
, typefield
;
9242 if (type
== NULL_TREE
)
9244 type
= make_node (RECORD_TYPE
);
9246 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9248 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9250 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9251 ffecom_f2c_ptr_to_ftnlen_type_node
);
9252 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9255 TYPE_FIELDS (type
) = namefield
;
9258 ggc_add_tree_root (&type
, 1);
9265 ffecom_vardesc_ (ffebld expr
)
9269 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9270 s
= ffebld_symter (expr
);
9272 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9275 tree vardesctype
= ffecom_type_vardesc_ ();
9283 static int mynumber
= 0;
9285 var
= build_decl (VAR_DECL
,
9286 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9289 TREE_STATIC (var
) = 1;
9290 DECL_INITIAL (var
) = error_mark_node
;
9292 var
= start_decl (var
, FALSE
);
9294 /* Process inits. */
9296 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9298 ffesymbol_text (s
));
9299 TREE_TYPE (nameinit
)
9300 = build_type_variant
9303 build_range_type (integer_type_node
,
9305 build_int_2 (i
, 0))),
9307 TREE_CONSTANT (nameinit
) = 1;
9308 TREE_STATIC (nameinit
) = 1;
9309 nameinit
= ffecom_1 (ADDR_EXPR
,
9310 build_pointer_type (TREE_TYPE (nameinit
)),
9313 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9315 dimsinit
= ffecom_vardesc_dims_ (s
);
9317 if (typeinit
== NULL_TREE
)
9319 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9320 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9321 int tc
= ffecom_f2c_typecode (bt
, kt
);
9324 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9327 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9329 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9331 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9333 TREE_CHAIN (TREE_CHAIN (varinits
))
9334 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9335 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9336 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9338 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9339 TREE_CONSTANT (varinits
) = 1;
9340 TREE_STATIC (varinits
) = 1;
9342 finish_decl (var
, varinits
, FALSE
);
9344 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9346 ffesymbol_hook (s
).vardesc_tree
= var
;
9349 return ffesymbol_hook (s
).vardesc_tree
;
9353 ffecom_vardesc_array_ (ffesymbol s
)
9357 tree item
= NULL_TREE
;
9360 static int mynumber
= 0;
9362 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9364 b
= ffebld_trail (b
), ++i
)
9368 t
= ffecom_vardesc_ (ffebld_head (b
));
9370 if (list
== NULL_TREE
)
9371 list
= item
= build_tree_list (NULL_TREE
, t
);
9374 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9375 item
= TREE_CHAIN (item
);
9379 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9380 build_range_type (integer_type_node
,
9382 build_int_2 (i
, 0)));
9383 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9384 TREE_CONSTANT (list
) = 1;
9385 TREE_STATIC (list
) = 1;
9387 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9388 var
= build_decl (VAR_DECL
, var
, item
);
9389 TREE_STATIC (var
) = 1;
9390 DECL_INITIAL (var
) = error_mark_node
;
9391 var
= start_decl (var
, FALSE
);
9392 finish_decl (var
, list
, FALSE
);
9398 ffecom_vardesc_dims_ (ffesymbol s
)
9400 if (ffesymbol_dims (s
) == NULL
)
9401 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9409 tree item
= NULL_TREE
;
9413 tree baseoff
= NULL_TREE
;
9414 static int mynumber
= 0;
9416 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9417 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9419 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9420 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9423 backlist
= NULL_TREE
;
9424 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9426 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9432 if (ffebld_trail (b
) == NULL
)
9436 t
= convert (ffecom_f2c_ftnlen_type_node
,
9437 ffecom_expr (ffebld_head (e
)));
9439 if (list
== NULL_TREE
)
9440 list
= item
= build_tree_list (NULL_TREE
, t
);
9443 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9444 item
= TREE_CHAIN (item
);
9448 if (ffebld_left (ffebld_head (b
)) == NULL
)
9449 low
= ffecom_integer_one_node
;
9451 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9452 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9454 back
= build_tree_list (low
, t
);
9455 TREE_CHAIN (back
) = backlist
;
9459 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9461 if (TREE_VALUE (item
) == NULL_TREE
)
9462 baseoff
= TREE_PURPOSE (item
);
9464 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9465 TREE_PURPOSE (item
),
9466 ffecom_2 (MULT_EXPR
,
9467 ffecom_f2c_ftnlen_type_node
,
9472 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9474 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9475 TREE_CHAIN (baseoff
) = list
;
9477 numelem
= build_tree_list (NULL_TREE
, numelem
);
9478 TREE_CHAIN (numelem
) = baseoff
;
9480 numdim
= build_tree_list (NULL_TREE
, numdim
);
9481 TREE_CHAIN (numdim
) = numelem
;
9483 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9484 build_range_type (integer_type_node
,
9487 ((int) ffesymbol_rank (s
)
9489 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9490 TREE_CONSTANT (list
) = 1;
9491 TREE_STATIC (list
) = 1;
9493 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9494 var
= build_decl (VAR_DECL
, var
, item
);
9495 TREE_STATIC (var
) = 1;
9496 DECL_INITIAL (var
) = error_mark_node
;
9497 var
= start_decl (var
, FALSE
);
9498 finish_decl (var
, list
, FALSE
);
9500 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9506 /* Essentially does a "fold (build1 (code, type, node))" while checking
9507 for certain housekeeping things.
9509 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9510 ffecom_1_fn instead. */
9513 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9517 if ((node
== error_mark_node
)
9518 || (type
== error_mark_node
))
9519 return error_mark_node
;
9521 if (code
== ADDR_EXPR
)
9523 if (!mark_addressable (node
))
9524 assert ("can't mark_addressable this node!" == NULL
);
9527 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9532 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9536 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9541 if (TREE_CODE (type
) != RECORD_TYPE
)
9543 item
= build1 (code
, type
, node
);
9546 node
= ffecom_stabilize_aggregate_ (node
);
9547 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9549 ffecom_2 (COMPLEX_EXPR
, type
,
9550 ffecom_1 (NEGATE_EXPR
, realtype
,
9551 ffecom_1 (REALPART_EXPR
, realtype
,
9553 ffecom_1 (NEGATE_EXPR
, realtype
,
9554 ffecom_1 (IMAGPART_EXPR
, realtype
,
9559 item
= build1 (code
, type
, node
);
9563 if (TREE_SIDE_EFFECTS (node
))
9564 TREE_SIDE_EFFECTS (item
) = 1;
9565 if (code
== ADDR_EXPR
&& staticp (node
))
9566 TREE_CONSTANT (item
) = 1;
9567 else if (code
== INDIRECT_REF
)
9568 TREE_READONLY (item
) = TYPE_READONLY (type
);
9572 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9573 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9574 does not set TREE_ADDRESSABLE (because calling an inline
9575 function does not mean the function needs to be separately
9579 ffecom_1_fn (tree node
)
9584 if (node
== error_mark_node
)
9585 return error_mark_node
;
9587 type
= build_type_variant (TREE_TYPE (node
),
9588 TREE_READONLY (node
),
9589 TREE_THIS_VOLATILE (node
));
9590 item
= build1 (ADDR_EXPR
,
9591 build_pointer_type (type
), node
);
9592 if (TREE_SIDE_EFFECTS (node
))
9593 TREE_SIDE_EFFECTS (item
) = 1;
9595 TREE_CONSTANT (item
) = 1;
9599 /* Essentially does a "fold (build (code, type, node1, node2))" while
9600 checking for certain housekeeping things. */
9603 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9608 if ((node1
== error_mark_node
)
9609 || (node2
== error_mark_node
)
9610 || (type
== error_mark_node
))
9611 return error_mark_node
;
9613 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9615 tree a
, b
, c
, d
, realtype
;
9618 assert ("no CONJ_EXPR support yet" == NULL
);
9619 return error_mark_node
;
9622 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9623 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9624 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9628 if (TREE_CODE (type
) != RECORD_TYPE
)
9630 item
= build (code
, type
, node1
, node2
);
9633 node1
= ffecom_stabilize_aggregate_ (node1
);
9634 node2
= ffecom_stabilize_aggregate_ (node2
);
9635 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9637 ffecom_2 (COMPLEX_EXPR
, type
,
9638 ffecom_2 (PLUS_EXPR
, realtype
,
9639 ffecom_1 (REALPART_EXPR
, realtype
,
9641 ffecom_1 (REALPART_EXPR
, realtype
,
9643 ffecom_2 (PLUS_EXPR
, realtype
,
9644 ffecom_1 (IMAGPART_EXPR
, realtype
,
9646 ffecom_1 (IMAGPART_EXPR
, realtype
,
9651 if (TREE_CODE (type
) != RECORD_TYPE
)
9653 item
= build (code
, type
, node1
, node2
);
9656 node1
= ffecom_stabilize_aggregate_ (node1
);
9657 node2
= ffecom_stabilize_aggregate_ (node2
);
9658 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9660 ffecom_2 (COMPLEX_EXPR
, type
,
9661 ffecom_2 (MINUS_EXPR
, realtype
,
9662 ffecom_1 (REALPART_EXPR
, realtype
,
9664 ffecom_1 (REALPART_EXPR
, realtype
,
9666 ffecom_2 (MINUS_EXPR
, realtype
,
9667 ffecom_1 (IMAGPART_EXPR
, realtype
,
9669 ffecom_1 (IMAGPART_EXPR
, realtype
,
9674 if (TREE_CODE (type
) != RECORD_TYPE
)
9676 item
= build (code
, type
, node1
, node2
);
9679 node1
= ffecom_stabilize_aggregate_ (node1
);
9680 node2
= ffecom_stabilize_aggregate_ (node2
);
9681 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9682 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9684 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9686 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9688 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9691 ffecom_2 (COMPLEX_EXPR
, type
,
9692 ffecom_2 (MINUS_EXPR
, realtype
,
9693 ffecom_2 (MULT_EXPR
, realtype
,
9696 ffecom_2 (MULT_EXPR
, realtype
,
9699 ffecom_2 (PLUS_EXPR
, realtype
,
9700 ffecom_2 (MULT_EXPR
, realtype
,
9703 ffecom_2 (MULT_EXPR
, realtype
,
9709 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9710 && (TREE_CODE (node2
) != RECORD_TYPE
))
9712 item
= build (code
, type
, node1
, node2
);
9715 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9716 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9717 node1
= ffecom_stabilize_aggregate_ (node1
);
9718 node2
= ffecom_stabilize_aggregate_ (node2
);
9719 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9721 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9722 ffecom_2 (code
, type
,
9723 ffecom_1 (REALPART_EXPR
, realtype
,
9725 ffecom_1 (REALPART_EXPR
, realtype
,
9727 ffecom_2 (code
, type
,
9728 ffecom_1 (IMAGPART_EXPR
, realtype
,
9730 ffecom_1 (IMAGPART_EXPR
, realtype
,
9735 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9736 && (TREE_CODE (node2
) != RECORD_TYPE
))
9738 item
= build (code
, type
, node1
, node2
);
9741 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9742 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9743 node1
= ffecom_stabilize_aggregate_ (node1
);
9744 node2
= ffecom_stabilize_aggregate_ (node2
);
9745 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9747 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9748 ffecom_2 (code
, type
,
9749 ffecom_1 (REALPART_EXPR
, realtype
,
9751 ffecom_1 (REALPART_EXPR
, realtype
,
9753 ffecom_2 (code
, type
,
9754 ffecom_1 (IMAGPART_EXPR
, realtype
,
9756 ffecom_1 (IMAGPART_EXPR
, realtype
,
9761 item
= build (code
, type
, node1
, node2
);
9765 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9766 TREE_SIDE_EFFECTS (item
) = 1;
9770 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9772 ffesymbol s; // the ENTRY point itself
9773 if (ffecom_2pass_advise_entrypoint(s))
9774 // the ENTRY point has been accepted
9776 Does whatever compiler needs to do when it learns about the entrypoint,
9777 like determine the return type of the master function, count the
9778 number of entrypoints, etc. Returns FALSE if the return type is
9779 not compatible with the return type(s) of other entrypoint(s).
9781 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9782 later (after _finish_progunit) be called with the same entrypoint(s)
9783 as passed to this fn for which TRUE was returned.
9786 Return FALSE if the return type conflicts with previous entrypoints. */
9789 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9791 ffebld list
; /* opITEM. */
9792 ffebld mlist
; /* opITEM. */
9793 ffebld plist
; /* opITEM. */
9794 ffebld arg
; /* ffebld_head(opITEM). */
9795 ffebld item
; /* opITEM. */
9796 ffesymbol s
; /* ffebld_symter(arg). */
9797 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9798 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9799 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9802 if (ffecom_num_entrypoints_
== 0)
9803 { /* First entrypoint, make list of main
9804 arglist's dummies. */
9805 assert (ffecom_primary_entry_
!= NULL
);
9807 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9808 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9809 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9811 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9813 list
= ffebld_trail (list
))
9815 arg
= ffebld_head (list
);
9816 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9817 continue; /* Alternate return or some such thing. */
9818 item
= ffebld_new_item (arg
, NULL
);
9820 ffecom_master_arglist_
= item
;
9822 ffebld_set_trail (plist
, item
);
9827 /* If necessary, scan entry arglist for alternate returns. Do this scan
9828 apparently redundantly (it's done below to UNIONize the arglists) so
9829 that we don't complain about RETURN 1 if an offending ENTRY is the only
9830 one with an alternate return. */
9832 if (!ffecom_is_altreturning_
)
9834 for (list
= ffesymbol_dummyargs (entry
);
9836 list
= ffebld_trail (list
))
9838 arg
= ffebld_head (list
);
9839 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9841 ffecom_is_altreturning_
= TRUE
;
9847 /* Now check type compatibility. */
9849 switch (ffecom_master_bt_
)
9851 case FFEINFO_basictypeNONE
:
9852 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
9855 case FFEINFO_basictypeCHARACTER
:
9857 = (bt
== FFEINFO_basictypeCHARACTER
)
9858 && (kt
== ffecom_master_kt_
)
9859 && (size
== ffecom_master_size_
);
9862 case FFEINFO_basictypeANY
:
9863 return FALSE
; /* Just don't bother. */
9866 if (bt
== FFEINFO_basictypeCHARACTER
)
9872 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
9874 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
9875 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
9882 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
9883 ffest_ffebad_here_current_stmt (0);
9885 return FALSE
; /* Can't handle entrypoint. */
9888 /* Entrypoint type compatible with previous types. */
9890 ++ffecom_num_entrypoints_
;
9892 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9894 for (list
= ffesymbol_dummyargs (entry
);
9896 list
= ffebld_trail (list
))
9898 arg
= ffebld_head (list
);
9899 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9900 continue; /* Alternate return or some such thing. */
9901 s
= ffebld_symter (arg
);
9902 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
9904 plist
= mlist
, mlist
= ffebld_trail (mlist
))
9905 { /* plist points to previous item for easy
9906 appending of arg. */
9907 if (ffebld_symter (ffebld_head (mlist
)) == s
)
9908 break; /* Already have this arg in the master list. */
9911 continue; /* Already have this arg in the master list. */
9913 /* Append this arg to the master list. */
9915 item
= ffebld_new_item (arg
, NULL
);
9917 ffecom_master_arglist_
= item
;
9919 ffebld_set_trail (plist
, item
);
9925 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9927 ffesymbol s; // the ENTRY point itself
9928 ffecom_2pass_do_entrypoint(s);
9930 Does whatever compiler needs to do to make the entrypoint actually
9931 happen. Must be called for each entrypoint after
9932 ffecom_finish_progunit is called. */
9935 ffecom_2pass_do_entrypoint (ffesymbol entry
)
9937 static int mfn_num
= 0;
9940 if (mfn_num
!= ffecom_num_fns_
)
9941 { /* First entrypoint for this program unit. */
9943 mfn_num
= ffecom_num_fns_
;
9944 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
9949 --ffecom_num_entrypoints_
;
9951 ffecom_do_entry_ (entry
, ent_num
);
9954 /* Essentially does a "fold (build (code, type, node1, node2))" while
9955 checking for certain housekeeping things. Always sets
9956 TREE_SIDE_EFFECTS. */
9959 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
9964 if ((node1
== error_mark_node
)
9965 || (node2
== error_mark_node
)
9966 || (type
== error_mark_node
))
9967 return error_mark_node
;
9969 item
= build (code
, type
, node1
, node2
);
9970 TREE_SIDE_EFFECTS (item
) = 1;
9974 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9975 checking for certain housekeeping things. */
9978 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
9979 tree node2
, tree node3
)
9983 if ((node1
== error_mark_node
)
9984 || (node2
== error_mark_node
)
9985 || (node3
== error_mark_node
)
9986 || (type
== error_mark_node
))
9987 return error_mark_node
;
9989 item
= build (code
, type
, node1
, node2
, node3
);
9990 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
9991 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
9992 TREE_SIDE_EFFECTS (item
) = 1;
9996 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9997 checking for certain housekeeping things. Always sets
9998 TREE_SIDE_EFFECTS. */
10001 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10002 tree node2
, tree node3
)
10006 if ((node1
== error_mark_node
)
10007 || (node2
== error_mark_node
)
10008 || (node3
== error_mark_node
)
10009 || (type
== error_mark_node
))
10010 return error_mark_node
;
10012 item
= build (code
, type
, node1
, node2
, node3
);
10013 TREE_SIDE_EFFECTS (item
) = 1;
10014 return fold (item
);
10017 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10019 See use by ffecom_list_expr.
10021 If expression is NULL, returns an integer zero tree. If it is not
10022 a CHARACTER expression, returns whatever ffecom_expr
10023 returns and sets the length return value to NULL_TREE. Otherwise
10024 generates code to evaluate the character expression, returns the proper
10025 pointer to the result, but does NOT set the length return value to a tree
10026 that specifies the length of the result. (In other words, the length
10027 variable is always set to NULL_TREE, because a length is never passed.)
10030 Don't set returned length, since nobody needs it (yet; someday if
10031 we allow CHARACTER*(*) dummies to statement functions, we'll need
10035 ffecom_arg_expr (ffebld expr
, tree
*length
)
10039 *length
= NULL_TREE
;
10042 return integer_zero_node
;
10044 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10045 return ffecom_expr (expr
);
10047 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10050 /* Transform expression into constant argument-pointer-to-expression tree.
10052 If the expression can be transformed into a argument-pointer-to-expression
10053 tree that is constant, that is done, and the tree returned. Else
10054 NULL_TREE is returned.
10056 That way, a caller can attempt to provide compile-time initialization
10057 of a variable and, if that fails, *then* choose to start a new block
10058 and resort to using temporaries, as appropriate. */
10061 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10064 return integer_zero_node
;
10066 if (ffebld_op (expr
) == FFEBLD_opANY
)
10069 *length
= error_mark_node
;
10070 return error_mark_node
;
10073 if (ffebld_arity (expr
) == 0
10074 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10075 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10076 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10077 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10081 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10082 assert (TREE_CONSTANT (t
));
10083 assert (! length
|| TREE_CONSTANT (*length
));
10088 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10089 *length
= build_int_2 (ffebld_size (expr
), 0);
10091 *length
= NULL_TREE
;
10095 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10097 See use by ffecom_list_ptr_to_expr.
10099 If expression is NULL, returns an integer zero tree. If it is not
10100 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10101 returns and sets the length return value to NULL_TREE. Otherwise
10102 generates code to evaluate the character expression, returns the proper
10103 pointer to the result, AND sets the length return value to a tree that
10104 specifies the length of the result.
10106 If the length argument is NULL, this is a slightly special
10107 case of building a FORMAT expression, that is, an expression that
10108 will be used at run time without regard to length. For the current
10109 implementation, which uses the libf2c library, this means it is nice
10110 to append a null byte to the end of the expression, where feasible,
10111 to make sure any diagnostic about the FORMAT string terminates at
10114 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10115 length argument. This might even be seen as a feature, if a null
10116 byte can always be appended. */
10119 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10123 ffecomConcatList_ catlist
;
10125 if (length
!= NULL
)
10126 *length
= NULL_TREE
;
10129 return integer_zero_node
;
10131 switch (ffebld_op (expr
))
10133 case FFEBLD_opPERCENT_VAL
:
10134 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10135 return ffecom_expr (ffebld_left (expr
));
10140 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10141 if (temp_exp
== error_mark_node
)
10142 return error_mark_node
;
10144 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10148 case FFEBLD_opPERCENT_REF
:
10149 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10150 return ffecom_ptr_to_expr (ffebld_left (expr
));
10151 if (length
!= NULL
)
10153 ign_length
= NULL_TREE
;
10154 length
= &ign_length
;
10156 expr
= ffebld_left (expr
);
10159 case FFEBLD_opPERCENT_DESCR
:
10160 switch (ffeinfo_basictype (ffebld_info (expr
)))
10162 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10163 case FFEINFO_basictypeHOLLERITH
:
10165 case FFEINFO_basictypeCHARACTER
:
10166 break; /* Passed by descriptor anyway. */
10169 item
= ffecom_ptr_to_expr (expr
);
10170 if (item
!= error_mark_node
)
10171 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10180 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10181 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10182 && (length
!= NULL
))
10183 { /* Pass Hollerith by descriptor. */
10184 ffetargetHollerith h
;
10186 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10187 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10188 (ffebld_conter (expr
)));
10190 = build_int_2 (h
.length
, 0);
10191 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10195 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10196 return ffecom_ptr_to_expr (expr
);
10198 assert (ffeinfo_kindtype (ffebld_info (expr
))
10199 == FFEINFO_kindtypeCHARACTER1
);
10201 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10202 expr
= ffebld_left (expr
);
10204 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10205 switch (ffecom_concat_list_count_ (catlist
))
10207 case 0: /* Shouldn't happen, but in case it does... */
10208 if (length
!= NULL
)
10210 *length
= ffecom_f2c_ftnlen_zero_node
;
10211 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10213 ffecom_concat_list_kill_ (catlist
);
10214 return null_pointer_node
;
10216 case 1: /* The (fairly) easy case. */
10217 if (length
== NULL
)
10218 ffecom_char_args_with_null_ (&item
, &ign_length
,
10219 ffecom_concat_list_expr_ (catlist
, 0));
10221 ffecom_char_args_ (&item
, length
,
10222 ffecom_concat_list_expr_ (catlist
, 0));
10223 ffecom_concat_list_kill_ (catlist
);
10224 assert (item
!= NULL_TREE
);
10227 default: /* Must actually concatenate things. */
10232 int count
= ffecom_concat_list_count_ (catlist
);
10243 ffetargetCharacterSize sz
;
10245 sz
= ffecom_concat_list_maxlen_ (catlist
);
10247 assert (sz
!= FFETARGET_charactersizeNONE
);
10252 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10253 FFETARGET_charactersizeNONE
, count
, TRUE
);
10256 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10257 FFETARGET_charactersizeNONE
, count
, TRUE
);
10258 temporary
= ffecom_push_tempvar (char_type_node
,
10264 hook
= ffebld_nonter_hook (expr
);
10266 assert (TREE_CODE (hook
) == TREE_VEC
);
10267 assert (TREE_VEC_LENGTH (hook
) == 3);
10268 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10269 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10270 temporary
= TREE_VEC_ELT (hook
, 2);
10274 known_length
= ffecom_f2c_ftnlen_zero_node
;
10276 for (i
= 0; i
< count
; ++i
)
10279 && (length
== NULL
))
10280 ffecom_char_args_with_null_ (&citem
, &clength
,
10281 ffecom_concat_list_expr_ (catlist
, i
));
10283 ffecom_char_args_ (&citem
, &clength
,
10284 ffecom_concat_list_expr_ (catlist
, i
));
10285 if ((citem
== error_mark_node
)
10286 || (clength
== error_mark_node
))
10288 ffecom_concat_list_kill_ (catlist
);
10289 *length
= error_mark_node
;
10290 return error_mark_node
;
10294 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10295 ffecom_modify (void_type_node
,
10296 ffecom_2 (ARRAY_REF
,
10297 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10299 build_int_2 (i
, 0)),
10302 clength
= ffecom_save_tree (clength
);
10303 if (length
!= NULL
)
10305 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10309 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10310 ffecom_modify (void_type_node
,
10311 ffecom_2 (ARRAY_REF
,
10312 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10314 build_int_2 (i
, 0)),
10319 temporary
= ffecom_1 (ADDR_EXPR
,
10320 build_pointer_type (TREE_TYPE (temporary
)),
10323 item
= build_tree_list (NULL_TREE
, temporary
);
10325 = build_tree_list (NULL_TREE
,
10326 ffecom_1 (ADDR_EXPR
,
10327 build_pointer_type (TREE_TYPE (items
)),
10329 TREE_CHAIN (TREE_CHAIN (item
))
10330 = build_tree_list (NULL_TREE
,
10331 ffecom_1 (ADDR_EXPR
,
10332 build_pointer_type (TREE_TYPE (lengths
)),
10334 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10337 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10338 convert (ffecom_f2c_ftnlen_type_node
,
10339 build_int_2 (count
, 0))));
10340 num
= build_int_2 (sz
, 0);
10341 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10342 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10343 = build_tree_list (NULL_TREE
, num
);
10345 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10346 TREE_SIDE_EFFECTS (item
) = 1;
10347 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10351 if (length
!= NULL
)
10352 *length
= known_length
;
10355 ffecom_concat_list_kill_ (catlist
);
10356 assert (item
!= NULL_TREE
);
10360 /* Generate call to run-time function.
10362 The first arg is the GNU Fortran Run-Time function index, the second
10363 arg is the list of arguments to pass to it. Returned is the expression
10364 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10365 result (which may be void). */
10368 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10370 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10371 ffecom_gfrt_kindtype (ix
),
10372 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10373 NULL_TREE
, args
, NULL_TREE
, NULL
,
10374 NULL
, NULL_TREE
, TRUE
, hook
);
10377 /* Transform constant-union to tree. */
10380 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10381 ffeinfoKindtype kt
, tree tree_type
)
10387 case FFEINFO_basictypeINTEGER
:
10393 #if FFETARGET_okINTEGER1
10394 case FFEINFO_kindtypeINTEGER1
:
10395 val
= ffebld_cu_val_integer1 (*cu
);
10399 #if FFETARGET_okINTEGER2
10400 case FFEINFO_kindtypeINTEGER2
:
10401 val
= ffebld_cu_val_integer2 (*cu
);
10405 #if FFETARGET_okINTEGER3
10406 case FFEINFO_kindtypeINTEGER3
:
10407 val
= ffebld_cu_val_integer3 (*cu
);
10411 #if FFETARGET_okINTEGER4
10412 case FFEINFO_kindtypeINTEGER4
:
10413 val
= ffebld_cu_val_integer4 (*cu
);
10418 assert ("bad INTEGER constant kind type" == NULL
);
10419 /* Fall through. */
10420 case FFEINFO_kindtypeANY
:
10421 return error_mark_node
;
10423 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10424 TREE_TYPE (item
) = tree_type
;
10428 case FFEINFO_basictypeLOGICAL
:
10434 #if FFETARGET_okLOGICAL1
10435 case FFEINFO_kindtypeLOGICAL1
:
10436 val
= ffebld_cu_val_logical1 (*cu
);
10440 #if FFETARGET_okLOGICAL2
10441 case FFEINFO_kindtypeLOGICAL2
:
10442 val
= ffebld_cu_val_logical2 (*cu
);
10446 #if FFETARGET_okLOGICAL3
10447 case FFEINFO_kindtypeLOGICAL3
:
10448 val
= ffebld_cu_val_logical3 (*cu
);
10452 #if FFETARGET_okLOGICAL4
10453 case FFEINFO_kindtypeLOGICAL4
:
10454 val
= ffebld_cu_val_logical4 (*cu
);
10459 assert ("bad LOGICAL constant kind type" == NULL
);
10460 /* Fall through. */
10461 case FFEINFO_kindtypeANY
:
10462 return error_mark_node
;
10464 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10465 TREE_TYPE (item
) = tree_type
;
10469 case FFEINFO_basictypeREAL
:
10471 REAL_VALUE_TYPE val
;
10475 #if FFETARGET_okREAL1
10476 case FFEINFO_kindtypeREAL1
:
10477 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10481 #if FFETARGET_okREAL2
10482 case FFEINFO_kindtypeREAL2
:
10483 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10487 #if FFETARGET_okREAL3
10488 case FFEINFO_kindtypeREAL3
:
10489 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10493 #if FFETARGET_okREAL4
10494 case FFEINFO_kindtypeREAL4
:
10495 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10500 assert ("bad REAL constant kind type" == NULL
);
10501 /* Fall through. */
10502 case FFEINFO_kindtypeANY
:
10503 return error_mark_node
;
10505 item
= build_real (tree_type
, val
);
10509 case FFEINFO_basictypeCOMPLEX
:
10511 REAL_VALUE_TYPE real
;
10512 REAL_VALUE_TYPE imag
;
10513 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10517 #if FFETARGET_okCOMPLEX1
10518 case FFEINFO_kindtypeREAL1
:
10519 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10520 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10524 #if FFETARGET_okCOMPLEX2
10525 case FFEINFO_kindtypeREAL2
:
10526 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10527 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10531 #if FFETARGET_okCOMPLEX3
10532 case FFEINFO_kindtypeREAL3
:
10533 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10534 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10538 #if FFETARGET_okCOMPLEX4
10539 case FFEINFO_kindtypeREAL4
:
10540 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10541 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10546 assert ("bad REAL constant kind type" == NULL
);
10547 /* Fall through. */
10548 case FFEINFO_kindtypeANY
:
10549 return error_mark_node
;
10551 item
= ffecom_build_complex_constant_ (tree_type
,
10552 build_real (el_type
, real
),
10553 build_real (el_type
, imag
));
10557 case FFEINFO_basictypeCHARACTER
:
10558 { /* Happens only in DATA and similar contexts. */
10559 ffetargetCharacter1 val
;
10563 #if FFETARGET_okCHARACTER1
10564 case FFEINFO_kindtypeLOGICAL1
:
10565 val
= ffebld_cu_val_character1 (*cu
);
10570 assert ("bad CHARACTER constant kind type" == NULL
);
10571 /* Fall through. */
10572 case FFEINFO_kindtypeANY
:
10573 return error_mark_node
;
10575 item
= build_string (ffetarget_length_character1 (val
),
10576 ffetarget_text_character1 (val
));
10578 = build_type_variant (build_array_type (char_type_node
,
10580 (integer_type_node
,
10583 (ffetarget_length_character1
10589 case FFEINFO_basictypeHOLLERITH
:
10591 ffetargetHollerith h
;
10593 h
= ffebld_cu_val_hollerith (*cu
);
10595 /* If not at least as wide as default INTEGER, widen it. */
10596 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10597 item
= build_string (h
.length
, h
.text
);
10600 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10602 memcpy (str
, h
.text
, h
.length
);
10603 memset (&str
[h
.length
], ' ',
10604 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10606 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10610 = build_type_variant (build_array_type (char_type_node
,
10612 (integer_type_node
,
10620 case FFEINFO_basictypeTYPELESS
:
10622 ffetargetInteger1 ival
;
10623 ffetargetTypeless tless
;
10626 tless
= ffebld_cu_val_typeless (*cu
);
10627 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10628 assert (error
== FFEBAD
);
10630 item
= build_int_2 ((int) ival
, 0);
10635 assert ("not yet on constant type" == NULL
);
10636 /* Fall through. */
10637 case FFEINFO_basictypeANY
:
10638 return error_mark_node
;
10641 TREE_CONSTANT (item
) = 1;
10646 /* Transform expression into constant tree.
10648 If the expression can be transformed into a tree that is constant,
10649 that is done, and the tree returned. Else NULL_TREE is returned.
10651 That way, a caller can attempt to provide compile-time initialization
10652 of a variable and, if that fails, *then* choose to start a new block
10653 and resort to using temporaries, as appropriate. */
10656 ffecom_const_expr (ffebld expr
)
10659 return integer_zero_node
;
10661 if (ffebld_op (expr
) == FFEBLD_opANY
)
10662 return error_mark_node
;
10664 if (ffebld_arity (expr
) == 0
10665 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10667 /* ~~Enable once common/equivalence is handled properly? */
10668 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10670 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10671 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10675 t
= ffecom_expr (expr
);
10676 assert (TREE_CONSTANT (t
));
10683 /* Handy way to make a field in a struct/union. */
10686 ffecom_decl_field (tree context
, tree prevfield
,
10687 const char *name
, tree type
)
10691 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10692 DECL_CONTEXT (field
) = context
;
10693 DECL_ALIGN (field
) = 0;
10694 DECL_USER_ALIGN (field
) = 0;
10695 if (prevfield
!= NULL_TREE
)
10696 TREE_CHAIN (prevfield
) = field
;
10702 ffecom_close_include (FILE *f
)
10704 ffecom_close_include_ (f
);
10708 ffecom_decode_include_option (char *spec
)
10710 return ffecom_decode_include_option_ (spec
);
10713 /* End a compound statement (block). */
10716 ffecom_end_compstmt (void)
10718 return bison_rule_compstmt_ ();
10721 /* ffecom_end_transition -- Perform end transition on all symbols
10723 ffecom_end_transition();
10725 Calls ffecom_sym_end_transition for each global and local symbol. */
10728 ffecom_end_transition ()
10732 if (ffe_is_ffedebug ())
10733 fprintf (dmpout
, "; end_stmt_transition\n");
10735 ffecom_list_blockdata_
= NULL
;
10736 ffecom_list_common_
= NULL
;
10738 ffesymbol_drive (ffecom_sym_end_transition
);
10739 if (ffe_is_ffedebug ())
10741 ffestorag_report ();
10744 ffecom_start_progunit_ ();
10746 for (item
= ffecom_list_blockdata_
;
10748 item
= ffebld_trail (item
))
10755 static int number
= 0;
10757 callee
= ffebld_head (item
);
10758 s
= ffebld_symter (callee
);
10759 t
= ffesymbol_hook (s
).decl_tree
;
10760 if (t
== NULL_TREE
)
10762 s
= ffecom_sym_transform_ (s
);
10763 t
= ffesymbol_hook (s
).decl_tree
;
10766 dt
= build_pointer_type (TREE_TYPE (t
));
10768 var
= build_decl (VAR_DECL
,
10769 ffecom_get_invented_identifier ("__g77_forceload_%d",
10772 DECL_EXTERNAL (var
) = 0;
10773 TREE_STATIC (var
) = 1;
10774 TREE_PUBLIC (var
) = 0;
10775 DECL_INITIAL (var
) = error_mark_node
;
10776 TREE_USED (var
) = 1;
10778 var
= start_decl (var
, FALSE
);
10780 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10782 finish_decl (var
, t
, FALSE
);
10785 /* This handles any COMMON areas that weren't referenced but have, for
10786 example, important initial data. */
10788 for (item
= ffecom_list_common_
;
10790 item
= ffebld_trail (item
))
10791 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10793 ffecom_list_common_
= NULL
;
10796 /* ffecom_exec_transition -- Perform exec transition on all symbols
10798 ffecom_exec_transition();
10800 Calls ffecom_sym_exec_transition for each global and local symbol.
10801 Make sure error updating not inhibited. */
10804 ffecom_exec_transition ()
10808 if (ffe_is_ffedebug ())
10809 fprintf (dmpout
, "; exec_stmt_transition\n");
10811 inhibited
= ffebad_inhibit ();
10812 ffebad_set_inhibit (FALSE
);
10814 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
10815 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10816 if (ffe_is_ffedebug ())
10818 ffestorag_report ();
10822 ffebad_set_inhibit (TRUE
);
10825 /* Handle assignment statement.
10827 Convert dest and source using ffecom_expr, then join them
10828 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10831 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
10838 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
10843 /* This attempts to replicate the test below, but must not be
10844 true when the test below is false. (Always err on the side
10845 of creating unused temporaries, to avoid ICEs.) */
10846 if (ffebld_op (dest
) != FFEBLD_opSYMTER
10847 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
10848 && (TREE_CODE (dest_tree
) != VAR_DECL
10849 || TREE_ADDRESSABLE (dest_tree
))))
10851 ffecom_prepare_expr_ (source
, dest
);
10856 ffecom_prepare_expr_ (source
, NULL
);
10860 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10862 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10863 create a temporary through which the assignment is to take place,
10864 since MODIFY_EXPR doesn't handle partial overlap properly. */
10865 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
10866 && ffecom_possible_partial_overlap_ (dest
, source
))
10868 assign_temp
= ffecom_make_tempvar ("complex_let",
10870 [ffebld_basictype (dest
)]
10871 [ffebld_kindtype (dest
)],
10872 FFETARGET_charactersizeNONE
,
10876 assign_temp
= NULL_TREE
;
10878 ffecom_prepare_end ();
10880 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
10881 if (dest_tree
== error_mark_node
)
10884 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
10885 || TREE_ADDRESSABLE (dest_tree
))
10886 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
10890 assert (! dest_used
);
10892 source_tree
= ffecom_expr (source
);
10894 if (source_tree
== error_mark_node
)
10898 expr_tree
= source_tree
;
10899 else if (assign_temp
)
10902 /* The back end understands a conceptual move (evaluate source;
10903 store into dest), so use that, in case it can determine
10904 that it is going to use, say, two registers as temporaries
10905 anyway. So don't use the temp (and someday avoid generating
10906 it, once this code starts triggering regularly). */
10907 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
10911 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10914 expand_expr_stmt (expr_tree
);
10915 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10921 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10925 expand_expr_stmt (expr_tree
);
10929 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
10930 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10932 ffecom_prepare_end ();
10934 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
10935 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
10939 /* ffecom_expr -- Transform expr into gcc tree
10942 ffebld expr; // FFE expression.
10943 tree = ffecom_expr(expr);
10945 Recursive descent on expr while making corresponding tree nodes and
10946 attaching type info and such. */
10949 ffecom_expr (ffebld expr
)
10951 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
10954 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10957 ffecom_expr_assign (ffebld expr
)
10959 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10962 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10965 ffecom_expr_assign_w (ffebld expr
)
10967 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10970 /* Transform expr for use as into read/write tree and stabilize the
10971 reference. Not for use on CHARACTER expressions.
10973 Recursive descent on expr while making corresponding tree nodes and
10974 attaching type info and such. */
10977 ffecom_expr_rw (tree type
, ffebld expr
)
10979 assert (expr
!= NULL
);
10980 /* Different target types not yet supported. */
10981 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10983 return stabilize_reference (ffecom_expr (expr
));
10986 /* Transform expr for use as into write tree and stabilize the
10987 reference. Not for use on CHARACTER expressions.
10989 Recursive descent on expr while making corresponding tree nodes and
10990 attaching type info and such. */
10993 ffecom_expr_w (tree type
, ffebld expr
)
10995 assert (expr
!= NULL
);
10996 /* Different target types not yet supported. */
10997 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10999 return stabilize_reference (ffecom_expr (expr
));
11002 /* Do global stuff. */
11005 ffecom_finish_compile ()
11007 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11008 assert (current_function_decl
== NULL_TREE
);
11010 ffeglobal_drive (ffecom_finish_global_
);
11013 /* Public entry point for front end to access finish_decl. */
11016 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11018 assert (!is_top_level
);
11019 finish_decl (decl
, init
, FALSE
);
11022 /* Finish a program unit. */
11025 ffecom_finish_progunit ()
11027 ffecom_end_compstmt ();
11029 ffecom_previous_function_decl_
= current_function_decl
;
11030 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11032 finish_function (0);
11035 /* Wrapper for get_identifier. pattern is sprintf-like. */
11038 ffecom_get_invented_identifier (const char *pattern
, ...)
11044 va_start (ap
, pattern
);
11045 if (vasprintf (&nam
, pattern
, ap
) == 0)
11048 decl
= get_identifier (nam
);
11050 IDENTIFIER_INVENTED (decl
) = 1;
11055 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11057 assert (gfrt
< FFECOM_gfrt
);
11059 switch (ffecom_gfrt_type_
[gfrt
])
11061 case FFECOM_rttypeVOID_
:
11062 case FFECOM_rttypeVOIDSTAR_
:
11063 return FFEINFO_basictypeNONE
;
11065 case FFECOM_rttypeFTNINT_
:
11066 return FFEINFO_basictypeINTEGER
;
11068 case FFECOM_rttypeINTEGER_
:
11069 return FFEINFO_basictypeINTEGER
;
11071 case FFECOM_rttypeLONGINT_
:
11072 return FFEINFO_basictypeINTEGER
;
11074 case FFECOM_rttypeLOGICAL_
:
11075 return FFEINFO_basictypeLOGICAL
;
11077 case FFECOM_rttypeREAL_F2C_
:
11078 case FFECOM_rttypeREAL_GNU_
:
11079 return FFEINFO_basictypeREAL
;
11081 case FFECOM_rttypeCOMPLEX_F2C_
:
11082 case FFECOM_rttypeCOMPLEX_GNU_
:
11083 return FFEINFO_basictypeCOMPLEX
;
11085 case FFECOM_rttypeDOUBLE_
:
11086 case FFECOM_rttypeDOUBLEREAL_
:
11087 return FFEINFO_basictypeREAL
;
11089 case FFECOM_rttypeDBLCMPLX_F2C_
:
11090 case FFECOM_rttypeDBLCMPLX_GNU_
:
11091 return FFEINFO_basictypeCOMPLEX
;
11093 case FFECOM_rttypeCHARACTER_
:
11094 return FFEINFO_basictypeCHARACTER
;
11097 return FFEINFO_basictypeANY
;
11102 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11104 assert (gfrt
< FFECOM_gfrt
);
11106 switch (ffecom_gfrt_type_
[gfrt
])
11108 case FFECOM_rttypeVOID_
:
11109 case FFECOM_rttypeVOIDSTAR_
:
11110 return FFEINFO_kindtypeNONE
;
11112 case FFECOM_rttypeFTNINT_
:
11113 return FFEINFO_kindtypeINTEGER1
;
11115 case FFECOM_rttypeINTEGER_
:
11116 return FFEINFO_kindtypeINTEGER1
;
11118 case FFECOM_rttypeLONGINT_
:
11119 return FFEINFO_kindtypeINTEGER4
;
11121 case FFECOM_rttypeLOGICAL_
:
11122 return FFEINFO_kindtypeLOGICAL1
;
11124 case FFECOM_rttypeREAL_F2C_
:
11125 case FFECOM_rttypeREAL_GNU_
:
11126 return FFEINFO_kindtypeREAL1
;
11128 case FFECOM_rttypeCOMPLEX_F2C_
:
11129 case FFECOM_rttypeCOMPLEX_GNU_
:
11130 return FFEINFO_kindtypeREAL1
;
11132 case FFECOM_rttypeDOUBLE_
:
11133 case FFECOM_rttypeDOUBLEREAL_
:
11134 return FFEINFO_kindtypeREAL2
;
11136 case FFECOM_rttypeDBLCMPLX_F2C_
:
11137 case FFECOM_rttypeDBLCMPLX_GNU_
:
11138 return FFEINFO_kindtypeREAL2
;
11140 case FFECOM_rttypeCHARACTER_
:
11141 return FFEINFO_kindtypeCHARACTER1
;
11144 return FFEINFO_kindtypeANY
;
11158 tree double_ftype_double
;
11159 tree float_ftype_float
;
11160 tree ldouble_ftype_ldouble
;
11161 tree ffecom_tree_ptr_to_fun_type_void
;
11163 /* This block of code comes from the now-obsolete cktyps.c. It checks
11164 whether the compiler environment is buggy in known ways, some of which
11165 would, if not explicitly checked here, result in subtle bugs in g77. */
11167 if (ffe_is_do_internal_checks ())
11169 static const char names
[][12]
11171 {"bar", "bletch", "foo", "foobar"};
11176 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11177 (int (*)(const void *, const void *)) strcmp
);
11178 if (name
!= &names
[0][2])
11180 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11185 ul
= strtoul ("123456789", NULL
, 10);
11186 if (ul
!= 123456789L)
11188 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11189 in proj.h" == NULL
);
11193 fl
= atof ("56.789");
11194 if ((fl
< 56.788) || (fl
> 56.79))
11196 assert ("atof not type double, fix your #include <stdio.h>"
11202 ffecom_outer_function_decl_
= NULL_TREE
;
11203 current_function_decl
= NULL_TREE
;
11204 named_labels
= NULL_TREE
;
11205 current_binding_level
= NULL_BINDING_LEVEL
;
11206 free_binding_level
= NULL_BINDING_LEVEL
;
11207 /* Make the binding_level structure for global names. */
11209 global_binding_level
= current_binding_level
;
11210 current_binding_level
->prep_state
= 2;
11212 build_common_tree_nodes (1);
11214 /* Define `int' and `char' first so that dbx will output them first. */
11215 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11216 integer_type_node
));
11217 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11218 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11219 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11221 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11222 long_integer_type_node
));
11223 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11224 unsigned_type_node
));
11225 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11226 long_unsigned_type_node
));
11227 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11228 long_long_integer_type_node
));
11229 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11230 long_long_unsigned_type_node
));
11231 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11232 short_integer_type_node
));
11233 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11234 short_unsigned_type_node
));
11236 /* Set the sizetype before we make other types. This *should* be the
11237 first type we create. */
11240 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11241 ffecom_typesize_pointer_
11242 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11244 build_common_tree_nodes_2 (0);
11246 /* Define both `signed char' and `unsigned char'. */
11247 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11248 signed_char_type_node
));
11250 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11251 unsigned_char_type_node
));
11253 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11255 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11256 double_type_node
));
11257 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11258 long_double_type_node
));
11260 /* For now, override what build_common_tree_nodes has done. */
11261 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11262 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11263 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11264 complex_long_double_type_node
11265 = ffecom_make_complex_type_ (long_double_type_node
);
11267 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11268 complex_integer_type_node
));
11269 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11270 complex_float_type_node
));
11271 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11272 complex_double_type_node
));
11273 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11274 complex_long_double_type_node
));
11276 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11278 /* We are not going to have real types in C with less than byte alignment,
11279 so we might as well not have any types that claim to have it. */
11280 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11281 TYPE_USER_ALIGN (void_type_node
) = 0;
11283 string_type_node
= build_pointer_type (char_type_node
);
11285 ffecom_tree_fun_type_void
11286 = build_function_type (void_type_node
, NULL_TREE
);
11288 ffecom_tree_ptr_to_fun_type_void
11289 = build_pointer_type (ffecom_tree_fun_type_void
);
11291 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11294 = build_function_type (float_type_node
,
11295 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11297 double_ftype_double
11298 = build_function_type (double_type_node
,
11299 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11301 ldouble_ftype_ldouble
11302 = build_function_type (long_double_type_node
,
11303 tree_cons (NULL_TREE
, long_double_type_node
,
11306 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11307 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11309 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11310 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11311 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11312 ffecom_f2c_typecode_
[i
][j
] = -1;
11315 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11316 to size FLOAT_TYPE_SIZE because they have to be the same size as
11317 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11318 Compiler options and other such stuff that change the ways these
11319 types are set should not affect this particular setup. */
11321 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11322 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11323 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11325 type
= ffetype_new ();
11327 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11329 ffetype_set_ams (type
,
11330 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11331 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11332 ffetype_set_star (base_type
,
11333 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11335 ffetype_set_kind (base_type
, 1, type
);
11336 ffecom_typesize_integer1_
= ffetype_size (type
);
11337 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11339 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11340 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11341 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11344 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11345 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11346 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11348 type
= ffetype_new ();
11349 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11351 ffetype_set_ams (type
,
11352 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11353 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11354 ffetype_set_star (base_type
,
11355 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11357 ffetype_set_kind (base_type
, 3, type
);
11358 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11360 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11361 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11362 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11365 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11366 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11367 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11369 type
= ffetype_new ();
11370 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11372 ffetype_set_ams (type
,
11373 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11374 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11375 ffetype_set_star (base_type
,
11376 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11378 ffetype_set_kind (base_type
, 6, type
);
11379 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11381 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11382 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11383 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11386 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11387 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11388 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11390 type
= ffetype_new ();
11391 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11393 ffetype_set_ams (type
,
11394 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11395 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11396 ffetype_set_star (base_type
,
11397 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11399 ffetype_set_kind (base_type
, 2, type
);
11400 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11402 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11403 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11404 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11408 if (ffe_is_do_internal_checks ()
11409 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11410 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11411 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11412 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11414 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11419 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11420 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11421 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11423 type
= ffetype_new ();
11425 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11427 ffetype_set_ams (type
,
11428 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11429 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11430 ffetype_set_star (base_type
,
11431 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11433 ffetype_set_kind (base_type
, 1, type
);
11434 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11436 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11437 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11438 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11440 type
= ffetype_new ();
11441 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11443 ffetype_set_ams (type
,
11444 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11445 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11446 ffetype_set_star (base_type
,
11447 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11449 ffetype_set_kind (base_type
, 3, type
);
11450 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11452 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11453 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11454 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11456 type
= ffetype_new ();
11457 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11459 ffetype_set_ams (type
,
11460 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11461 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11462 ffetype_set_star (base_type
,
11463 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11465 ffetype_set_kind (base_type
, 6, type
);
11466 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11468 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11469 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11470 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11472 type
= ffetype_new ();
11473 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11475 ffetype_set_ams (type
,
11476 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11477 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11478 ffetype_set_star (base_type
,
11479 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11481 ffetype_set_kind (base_type
, 2, type
);
11482 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11484 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11485 = t
= make_node (REAL_TYPE
);
11486 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11487 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11490 type
= ffetype_new ();
11492 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11494 ffetype_set_ams (type
,
11495 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11496 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11497 ffetype_set_star (base_type
,
11498 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11500 ffetype_set_kind (base_type
, 1, type
);
11501 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11502 = FFETARGET_f2cTYREAL
;
11503 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11505 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11506 = t
= make_node (REAL_TYPE
);
11507 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11508 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11511 type
= ffetype_new ();
11512 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11514 ffetype_set_ams (type
,
11515 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11516 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11517 ffetype_set_star (base_type
,
11518 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11520 ffetype_set_kind (base_type
, 2, type
);
11521 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11522 = FFETARGET_f2cTYDREAL
;
11523 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11525 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11526 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11527 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11529 type
= ffetype_new ();
11531 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11533 ffetype_set_ams (type
,
11534 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11535 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11536 ffetype_set_star (base_type
,
11537 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11539 ffetype_set_kind (base_type
, 1, type
);
11540 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11541 = FFETARGET_f2cTYCOMPLEX
;
11542 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11544 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11545 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11546 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11548 type
= ffetype_new ();
11549 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11551 ffetype_set_ams (type
,
11552 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11553 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11554 ffetype_set_star (base_type
,
11555 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11557 ffetype_set_kind (base_type
, 2,
11559 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11560 = FFETARGET_f2cTYDCOMPLEX
;
11561 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11563 /* Make function and ptr-to-function types for non-CHARACTER types. */
11565 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11566 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11568 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11570 if (i
== FFEINFO_basictypeINTEGER
)
11572 /* Figure out the smallest INTEGER type that can hold
11573 a pointer on this machine. */
11574 if (GET_MODE_SIZE (TYPE_MODE (t
))
11575 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11577 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11578 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11579 > GET_MODE_SIZE (TYPE_MODE (t
))))
11580 ffecom_pointer_kind_
= j
;
11583 else if (i
== FFEINFO_basictypeCOMPLEX
)
11584 t
= void_type_node
;
11585 /* For f2c compatibility, REAL functions are really
11586 implemented as DOUBLE PRECISION. */
11587 else if ((i
== FFEINFO_basictypeREAL
)
11588 && (j
== FFEINFO_kindtypeREAL1
))
11589 t
= ffecom_tree_type
11590 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11592 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11594 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11598 /* Set up pointer types. */
11600 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11601 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11602 else if (0 && ffe_is_do_internal_checks ())
11603 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11604 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11605 FFEINFO_kindtypeINTEGERDEFAULT
),
11607 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11608 ffecom_pointer_kind_
));
11610 if (ffe_is_ugly_assign ())
11611 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11613 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11614 if (0 && ffe_is_do_internal_checks ())
11615 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11617 ffecom_integer_type_node
11618 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11619 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11620 integer_zero_node
);
11621 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11624 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11625 Turns out that by TYLONG, runtime/libI77/lio.h really means
11626 "whatever size an ftnint is". For consistency and sanity,
11627 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11628 all are INTEGER, which we also make out of whatever back-end
11629 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11630 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11631 accommodate machines like the Alpha. Note that this suggests
11632 f2c and libf2c are missing a distinction perhaps needed on
11633 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11635 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11636 FFETARGET_f2cTYLONG
);
11637 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11638 FFETARGET_f2cTYSHORT
);
11639 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11640 FFETARGET_f2cTYINT1
);
11641 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11642 FFETARGET_f2cTYQUAD
);
11643 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11644 FFETARGET_f2cTYLOGICAL
);
11645 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11646 FFETARGET_f2cTYLOGICAL2
);
11647 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11648 FFETARGET_f2cTYLOGICAL1
);
11649 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11650 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11651 FFETARGET_f2cTYQUAD
);
11653 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11654 loop. CHARACTER items are built as arrays of unsigned char. */
11656 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11657 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11658 type
= ffetype_new ();
11660 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11661 FFEINFO_kindtypeCHARACTER1
,
11663 ffetype_set_ams (type
,
11664 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11665 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11666 ffetype_set_kind (base_type
, 1, type
);
11667 assert (ffetype_size (type
)
11668 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11670 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11671 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11672 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11673 [FFEINFO_kindtypeCHARACTER1
]
11674 = ffecom_tree_ptr_to_fun_type_void
;
11675 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11676 = FFETARGET_f2cTYCHAR
;
11678 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11681 /* Make multi-return-value type and fields. */
11683 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11687 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11688 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11692 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11693 continue; /* Not supported. */
11694 sprintf (&name
[0], "bt_%s_kt_%s",
11695 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11696 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11697 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11698 get_identifier (name
),
11699 ffecom_tree_type
[i
][j
]);
11700 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11701 = ffecom_multi_type_node_
;
11702 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11703 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11704 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11705 field
= ffecom_multi_fields_
[i
][j
];
11708 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11709 layout_type (ffecom_multi_type_node_
);
11711 /* Subroutines usually return integer because they might have alternate
11714 ffecom_tree_subr_type
11715 = build_function_type (integer_type_node
, NULL_TREE
);
11716 ffecom_tree_ptr_to_subr_type
11717 = build_pointer_type (ffecom_tree_subr_type
);
11718 ffecom_tree_blockdata_type
11719 = build_function_type (void_type_node
, NULL_TREE
);
11721 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11722 BUILT_IN_SQRTF
, BUILT_IN_NORMAL
, "sqrtf");
11723 builtin_function ("__builtin_sqrt", double_ftype_double
,
11724 BUILT_IN_SQRT
, BUILT_IN_NORMAL
, "sqrt");
11725 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11726 BUILT_IN_SQRTL
, BUILT_IN_NORMAL
, "sqrtl");
11727 builtin_function ("__builtin_sinf", float_ftype_float
,
11728 BUILT_IN_SINF
, BUILT_IN_NORMAL
, "sinf");
11729 builtin_function ("__builtin_sin", double_ftype_double
,
11730 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin");
11731 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11732 BUILT_IN_SINL
, BUILT_IN_NORMAL
, "sinl");
11733 builtin_function ("__builtin_cosf", float_ftype_float
,
11734 BUILT_IN_COSF
, BUILT_IN_NORMAL
, "cosf");
11735 builtin_function ("__builtin_cos", double_ftype_double
,
11736 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos");
11737 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11738 BUILT_IN_COSL
, BUILT_IN_NORMAL
, "cosl");
11740 pedantic_lvalues
= FALSE
;
11742 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11745 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11748 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11751 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11752 FFECOM_f2cDOUBLEREAL
,
11754 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11757 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11758 FFECOM_f2cDOUBLECOMPLEX
,
11760 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11763 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11766 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11769 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11772 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
11776 ffecom_f2c_ftnlen_zero_node
11777 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
11779 ffecom_f2c_ftnlen_one_node
11780 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
11782 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
11783 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
11785 ffecom_f2c_ptr_to_ftnlen_type_node
11786 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
11788 ffecom_f2c_ptr_to_ftnint_type_node
11789 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
11791 ffecom_f2c_ptr_to_integer_type_node
11792 = build_pointer_type (ffecom_f2c_integer_type_node
);
11794 ffecom_f2c_ptr_to_real_type_node
11795 = build_pointer_type (ffecom_f2c_real_type_node
);
11797 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
11798 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
11800 REAL_VALUE_TYPE point_5
;
11802 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
11803 ffecom_float_half_
= build_real (float_type_node
, point_5
);
11804 ffecom_double_half_
= build_real (double_type_node
, point_5
);
11807 /* Do "extern int xargc;". */
11809 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
11810 get_identifier ("f__xargc"),
11811 integer_type_node
);
11812 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
11813 TREE_STATIC (ffecom_tree_xargc_
) = 1;
11814 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
11815 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
11816 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
11818 #if 0 /* This is being fixed, and seems to be working now. */
11819 if ((FLOAT_TYPE_SIZE
!= 32)
11820 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
11822 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11823 (int) FLOAT_TYPE_SIZE
);
11824 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11825 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
11826 warning ("properly unless they all are 32 bits wide");
11827 warning ("Please keep this in mind before you report bugs.");
11831 #if 0 /* Code in ste.c that would crash has been commented out. */
11832 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
11833 < TYPE_PRECISION (string_type_node
))
11834 /* I/O will probably crash. */
11835 warning ("configuration: char * holds %d bits, but ftnlen only %d",
11836 TYPE_PRECISION (string_type_node
),
11837 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
11840 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
11841 if (TYPE_PRECISION (ffecom_integer_type_node
)
11842 < TYPE_PRECISION (string_type_node
))
11843 /* ASSIGN 10 TO I will crash. */
11844 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11845 ASSIGN statement might fail",
11846 TYPE_PRECISION (string_type_node
),
11847 TYPE_PRECISION (ffecom_integer_type_node
));
11851 /* ffecom_init_2 -- Initialize
11853 ffecom_init_2(); */
11858 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11859 assert (current_function_decl
== NULL_TREE
);
11860 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
11862 ffecom_master_arglist_
= NULL
;
11864 ffecom_primary_entry_
= NULL
;
11865 ffecom_is_altreturning_
= FALSE
;
11866 ffecom_func_result_
= NULL_TREE
;
11867 ffecom_multi_retval_
= NULL_TREE
;
11870 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11873 ffebld expr; // FFE opITEM list.
11874 tree = ffecom_list_expr(expr);
11876 List of actual args is transformed into corresponding gcc backend list. */
11879 ffecom_list_expr (ffebld expr
)
11882 tree
*plist
= &list
;
11883 tree trail
= NULL_TREE
; /* Append char length args here. */
11884 tree
*ptrail
= &trail
;
11887 while (expr
!= NULL
)
11889 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
11891 if (texpr
== error_mark_node
)
11892 return error_mark_node
;
11894 *plist
= build_tree_list (NULL_TREE
, texpr
);
11895 plist
= &TREE_CHAIN (*plist
);
11896 expr
= ffebld_trail (expr
);
11897 if (length
!= NULL_TREE
)
11899 *ptrail
= build_tree_list (NULL_TREE
, length
);
11900 ptrail
= &TREE_CHAIN (*ptrail
);
11909 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11912 ffebld expr; // FFE opITEM list.
11913 tree = ffecom_list_ptr_to_expr(expr);
11915 List of actual args is transformed into corresponding gcc backend list for
11916 use in calling an external procedure (vs. a statement function). */
11919 ffecom_list_ptr_to_expr (ffebld expr
)
11922 tree
*plist
= &list
;
11923 tree trail
= NULL_TREE
; /* Append char length args here. */
11924 tree
*ptrail
= &trail
;
11927 while (expr
!= NULL
)
11929 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
11931 if (texpr
== error_mark_node
)
11932 return error_mark_node
;
11934 *plist
= build_tree_list (NULL_TREE
, texpr
);
11935 plist
= &TREE_CHAIN (*plist
);
11936 expr
= ffebld_trail (expr
);
11937 if (length
!= NULL_TREE
)
11939 *ptrail
= build_tree_list (NULL_TREE
, length
);
11940 ptrail
= &TREE_CHAIN (*ptrail
);
11949 /* Obtain gcc's LABEL_DECL tree for label. */
11952 ffecom_lookup_label (ffelab label
)
11956 if (ffelab_hook (label
) == NULL_TREE
)
11958 char labelname
[16];
11960 switch (ffelab_type (label
))
11962 case FFELAB_typeLOOPEND
:
11963 case FFELAB_typeNOTLOOP
:
11964 case FFELAB_typeENDIF
:
11965 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
11966 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
11968 DECL_CONTEXT (glabel
) = current_function_decl
;
11969 DECL_MODE (glabel
) = VOIDmode
;
11972 case FFELAB_typeFORMAT
:
11973 glabel
= build_decl (VAR_DECL
,
11974 ffecom_get_invented_identifier
11975 ("__g77_format_%d", (int) ffelab_value (label
)),
11976 build_type_variant (build_array_type
11980 TREE_CONSTANT (glabel
) = 1;
11981 TREE_STATIC (glabel
) = 1;
11982 DECL_CONTEXT (glabel
) = current_function_decl
;
11983 DECL_INITIAL (glabel
) = NULL
;
11984 make_decl_rtl (glabel
, NULL
);
11985 expand_decl (glabel
);
11987 ffecom_save_tree_forever (glabel
);
11991 case FFELAB_typeANY
:
11992 glabel
= error_mark_node
;
11996 assert ("bad label type" == NULL
);
12000 ffelab_set_hook (label
, glabel
);
12004 glabel
= ffelab_hook (label
);
12010 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12011 a single source specification (as in the fourth argument of MVBITS).
12012 If the type is NULL_TREE, the type of lhs is used to make the type of
12013 the MODIFY_EXPR. */
12016 ffecom_modify (tree newtype
, tree lhs
,
12019 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12020 return error_mark_node
;
12022 if (newtype
== NULL_TREE
)
12023 newtype
= TREE_TYPE (lhs
);
12025 if (TREE_SIDE_EFFECTS (lhs
))
12026 lhs
= stabilize_reference (lhs
);
12028 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12031 /* Register source file name. */
12034 ffecom_file (const char *name
)
12036 ffecom_file_ (name
);
12039 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12042 ffecom_notify_init_storage(st);
12044 Gets called when all possible units in an aggregate storage area (a LOCAL
12045 with equivalences or a COMMON) have been initialized. The initialization
12046 info either is in ffestorag_init or, if that is NULL,
12047 ffestorag_accretion:
12049 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12050 even for an array if the array is one element in length!
12052 ffestorag_accretion will contain an opACCTER. It is much like an
12053 opARRTER except it has an ffebit object in it instead of just a size.
12054 The back end can use the info in the ffebit object, if it wants, to
12055 reduce the amount of actual initialization, but in any case it should
12056 kill the ffebit object when done. Also, set accretion to NULL but
12057 init to a non-NULL value.
12059 After performing initialization, DO NOT set init to NULL, because that'll
12060 tell the front end it is ok for more initialization to happen. Instead,
12061 set init to an opANY expression or some such thing that you can use to
12062 tell that you've already initialized the object.
12065 Support two-pass FFE. */
12068 ffecom_notify_init_storage (ffestorag st
)
12070 ffebld init
; /* The initialization expression. */
12072 if (ffestorag_init (st
) == NULL
)
12074 init
= ffestorag_accretion (st
);
12075 assert (init
!= NULL
);
12076 ffestorag_set_accretion (st
, NULL
);
12077 ffestorag_set_accretes (st
, 0);
12078 ffestorag_set_init (st
, init
);
12082 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12085 ffecom_notify_init_symbol(s);
12087 Gets called when all possible units in a symbol (not placed in COMMON
12088 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12089 have been initialized. The initialization info either is in
12090 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12092 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12093 even for an array if the array is one element in length!
12095 ffesymbol_accretion will contain an opACCTER. It is much like an
12096 opARRTER except it has an ffebit object in it instead of just a size.
12097 The back end can use the info in the ffebit object, if it wants, to
12098 reduce the amount of actual initialization, but in any case it should
12099 kill the ffebit object when done. Also, set accretion to NULL but
12100 init to a non-NULL value.
12102 After performing initialization, DO NOT set init to NULL, because that'll
12103 tell the front end it is ok for more initialization to happen. Instead,
12104 set init to an opANY expression or some such thing that you can use to
12105 tell that you've already initialized the object.
12108 Support two-pass FFE. */
12111 ffecom_notify_init_symbol (ffesymbol s
)
12113 ffebld init
; /* The initialization expression. */
12115 if (ffesymbol_storage (s
) == NULL
)
12116 return; /* Do nothing until COMMON/EQUIVALENCE
12117 possibilities checked. */
12119 if ((ffesymbol_init (s
) == NULL
)
12120 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12122 ffesymbol_set_accretion (s
, NULL
);
12123 ffesymbol_set_accretes (s
, 0);
12124 ffesymbol_set_init (s
, init
);
12128 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12131 ffecom_notify_primary_entry(s);
12133 Gets called when implicit or explicit PROGRAM statement seen or when
12134 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12135 global symbol that serves as the entry point. */
12138 ffecom_notify_primary_entry (ffesymbol s
)
12140 ffecom_primary_entry_
= s
;
12141 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12143 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12144 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12145 ffecom_primary_entry_is_proc_
= TRUE
;
12147 ffecom_primary_entry_is_proc_
= FALSE
;
12149 if (!ffe_is_silent ())
12151 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12152 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12154 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12157 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12162 for (list
= ffesymbol_dummyargs (s
);
12164 list
= ffebld_trail (list
))
12166 arg
= ffebld_head (list
);
12167 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12169 ffecom_is_altreturning_
= TRUE
;
12177 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12179 return ffecom_open_include_ (name
, l
, c
);
12182 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12185 ffebld expr; // FFE expression.
12186 tree = ffecom_ptr_to_expr(expr);
12188 Like ffecom_expr, but sticks address-of in front of most things. */
12191 ffecom_ptr_to_expr (ffebld expr
)
12194 ffeinfoBasictype bt
;
12195 ffeinfoKindtype kt
;
12198 assert (expr
!= NULL
);
12200 switch (ffebld_op (expr
))
12202 case FFEBLD_opSYMTER
:
12203 s
= ffebld_symter (expr
);
12204 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12208 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12209 assert (ix
!= FFECOM_gfrt
);
12210 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12212 ffecom_make_gfrt_ (ix
);
12213 item
= ffecom_gfrt_
[ix
];
12218 item
= ffesymbol_hook (s
).decl_tree
;
12219 if (item
== NULL_TREE
)
12221 s
= ffecom_sym_transform_ (s
);
12222 item
= ffesymbol_hook (s
).decl_tree
;
12225 assert (item
!= NULL
);
12226 if (item
== error_mark_node
)
12228 if (!ffesymbol_hook (s
).addr
)
12229 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12233 case FFEBLD_opARRAYREF
:
12234 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12236 case FFEBLD_opCONTER
:
12238 bt
= ffeinfo_basictype (ffebld_info (expr
));
12239 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12241 item
= ffecom_constantunion (&ffebld_constant_union
12242 (ffebld_conter (expr
)), bt
, kt
,
12243 ffecom_tree_type
[bt
][kt
]);
12244 if (item
== error_mark_node
)
12245 return error_mark_node
;
12246 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12251 return error_mark_node
;
12254 bt
= ffeinfo_basictype (ffebld_info (expr
));
12255 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12257 item
= ffecom_expr (expr
);
12258 if (item
== error_mark_node
)
12259 return error_mark_node
;
12261 /* The back end currently optimizes a bit too zealously for us, in that
12262 we fail JCB001 if the following block of code is omitted. It checks
12263 to see if the transformed expression is a symbol or array reference,
12264 and encloses it in a SAVE_EXPR if that is the case. */
12267 if ((TREE_CODE (item
) == VAR_DECL
)
12268 || (TREE_CODE (item
) == PARM_DECL
)
12269 || (TREE_CODE (item
) == RESULT_DECL
)
12270 || (TREE_CODE (item
) == INDIRECT_REF
)
12271 || (TREE_CODE (item
) == ARRAY_REF
)
12272 || (TREE_CODE (item
) == COMPONENT_REF
)
12274 || (TREE_CODE (item
) == OFFSET_REF
)
12276 || (TREE_CODE (item
) == BUFFER_REF
)
12277 || (TREE_CODE (item
) == REALPART_EXPR
)
12278 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12280 item
= ffecom_save_tree (item
);
12283 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12288 assert ("fall-through error" == NULL
);
12289 return error_mark_node
;
12292 /* Obtain a temp var with given data type.
12294 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12295 or >= 0 for a CHARACTER type.
12297 elements is -1 for a scalar or > 0 for an array of type. */
12300 ffecom_make_tempvar (const char *commentary
, tree type
,
12301 ffetargetCharacterSize size
, int elements
)
12304 static int mynumber
;
12306 assert (current_binding_level
->prep_state
< 2);
12308 if (type
== error_mark_node
)
12309 return error_mark_node
;
12311 if (size
!= FFETARGET_charactersizeNONE
)
12312 type
= build_array_type (type
,
12313 build_range_type (ffecom_f2c_ftnlen_type_node
,
12314 ffecom_f2c_ftnlen_one_node
,
12315 build_int_2 (size
, 0)));
12316 if (elements
!= -1)
12317 type
= build_array_type (type
,
12318 build_range_type (integer_type_node
,
12320 build_int_2 (elements
- 1,
12322 t
= build_decl (VAR_DECL
,
12323 ffecom_get_invented_identifier ("__g77_%s_%d",
12328 t
= start_decl (t
, FALSE
);
12329 finish_decl (t
, NULL_TREE
, FALSE
);
12334 /* Prepare argument pointer to expression.
12336 Like ffecom_prepare_expr, except for expressions to be evaluated
12337 via ffecom_arg_ptr_to_expr. */
12340 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12342 /* ~~For now, it seems to be the same thing. */
12343 ffecom_prepare_expr (expr
);
12347 /* End of preparations. */
12350 ffecom_prepare_end (void)
12352 int prep_state
= current_binding_level
->prep_state
;
12354 assert (prep_state
< 2);
12355 current_binding_level
->prep_state
= 2;
12357 return (prep_state
== 1) ? TRUE
: FALSE
;
12360 /* Prepare expression.
12362 This is called before any code is generated for the current block.
12363 It scans the expression, declares any temporaries that might be needed
12364 during evaluation of the expression, and stores those temporaries in
12365 the appropriate "hook" fields of the expression. `dest', if not NULL,
12366 specifies the destination that ffecom_expr_ will see, in case that
12367 helps avoid generating unused temporaries.
12369 ~~Improve to avoid allocating unused temporaries by taking `dest'
12370 into account vis-a-vis aliasing requirements of complex/character
12374 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12376 ffeinfoBasictype bt
;
12377 ffeinfoKindtype kt
;
12378 ffetargetCharacterSize sz
;
12379 tree tempvar
= NULL_TREE
;
12381 assert (current_binding_level
->prep_state
< 2);
12386 bt
= ffeinfo_basictype (ffebld_info (expr
));
12387 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12388 sz
= ffeinfo_size (ffebld_info (expr
));
12390 /* Generate whatever temporaries are needed to represent the result
12391 of the expression. */
12393 if (bt
== FFEINFO_basictypeCHARACTER
)
12395 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12396 expr
= ffebld_left (expr
);
12399 switch (ffebld_op (expr
))
12402 /* Don't make temps for SYMTER, CONTER, etc. */
12403 if (ffebld_arity (expr
) == 0)
12408 case FFEINFO_basictypeCOMPLEX
:
12409 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12413 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12416 s
= ffebld_symter (ffebld_left (expr
));
12417 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12418 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12419 && ! ffesymbol_is_f2c (s
))
12420 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12421 && ! ffe_is_f2c_library ()))
12424 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12426 /* Requires special treatment. There's no POW_CC function
12427 in libg2c, so POW_ZZ is used, which means we always
12428 need a double-complex temp, not a single-complex. */
12429 kt
= FFEINFO_kindtypeREAL2
;
12431 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12432 /* The other ops don't need temps for complex operands. */
12435 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12436 REAL(C). See 19990325-0.f, routine `check', for cases. */
12437 tempvar
= ffecom_make_tempvar ("complex",
12439 [FFEINFO_basictypeCOMPLEX
][kt
],
12440 FFETARGET_charactersizeNONE
,
12444 case FFEINFO_basictypeCHARACTER
:
12445 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12448 if (sz
== FFETARGET_charactersizeNONE
)
12449 /* ~~Kludge alert! This should someday be fixed. */
12452 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12461 case FFEBLD_opPOWER
:
12464 tree rtmp
, ltmp
, result
;
12466 ltype
= ffecom_type_expr (ffebld_left (expr
));
12467 rtype
= ffecom_type_expr (ffebld_right (expr
));
12469 rtmp
= ffecom_make_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1);
12470 ltmp
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12471 result
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12473 tempvar
= make_tree_vec (3);
12474 TREE_VEC_ELT (tempvar
, 0) = rtmp
;
12475 TREE_VEC_ELT (tempvar
, 1) = ltmp
;
12476 TREE_VEC_ELT (tempvar
, 2) = result
;
12481 case FFEBLD_opCONCATENATE
:
12483 /* This gets special handling, because only one set of temps
12484 is needed for a tree of these -- the tree is treated as
12485 a flattened list of concatenations when generating code. */
12487 ffecomConcatList_ catlist
;
12488 tree ltmp
, itmp
, result
;
12492 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12493 count
= ffecom_concat_list_count_ (catlist
);
12498 = ffecom_make_tempvar ("concat_len",
12499 ffecom_f2c_ftnlen_type_node
,
12500 FFETARGET_charactersizeNONE
, count
);
12502 = ffecom_make_tempvar ("concat_item",
12503 ffecom_f2c_address_type_node
,
12504 FFETARGET_charactersizeNONE
, count
);
12506 = ffecom_make_tempvar ("concat_res",
12508 ffecom_concat_list_maxlen_ (catlist
),
12511 tempvar
= make_tree_vec (3);
12512 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12513 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12514 TREE_VEC_ELT (tempvar
, 2) = result
;
12517 for (i
= 0; i
< count
; ++i
)
12518 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12521 ffecom_concat_list_kill_ (catlist
);
12525 ffebld_nonter_set_hook (expr
, tempvar
);
12526 current_binding_level
->prep_state
= 1;
12531 case FFEBLD_opCONVERT
:
12532 if (bt
== FFEINFO_basictypeCHARACTER
12533 && ((ffebld_size_known (ffebld_left (expr
))
12534 == FFETARGET_charactersizeNONE
)
12535 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12536 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12542 ffebld_nonter_set_hook (expr
, tempvar
);
12543 current_binding_level
->prep_state
= 1;
12546 /* Prepare subexpressions for this expr. */
12548 switch (ffebld_op (expr
))
12550 case FFEBLD_opPERCENT_LOC
:
12551 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12554 case FFEBLD_opPERCENT_VAL
:
12555 case FFEBLD_opPERCENT_REF
:
12556 ffecom_prepare_expr (ffebld_left (expr
));
12559 case FFEBLD_opPERCENT_DESCR
:
12560 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12563 case FFEBLD_opITEM
:
12569 item
= ffebld_trail (item
))
12570 if (ffebld_head (item
) != NULL
)
12571 ffecom_prepare_expr (ffebld_head (item
));
12576 /* Need to handle character conversion specially. */
12577 switch (ffebld_arity (expr
))
12580 ffecom_prepare_expr (ffebld_left (expr
));
12581 ffecom_prepare_expr (ffebld_right (expr
));
12585 ffecom_prepare_expr (ffebld_left (expr
));
12596 /* Prepare expression for reading and writing.
12598 Like ffecom_prepare_expr, except for expressions to be evaluated
12599 via ffecom_expr_rw. */
12602 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12604 /* This is all we support for now. */
12605 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12607 /* ~~For now, it seems to be the same thing. */
12608 ffecom_prepare_expr (expr
);
12612 /* Prepare expression for writing.
12614 Like ffecom_prepare_expr, except for expressions to be evaluated
12615 via ffecom_expr_w. */
12618 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12620 /* This is all we support for now. */
12621 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12623 /* ~~For now, it seems to be the same thing. */
12624 ffecom_prepare_expr (expr
);
12628 /* Prepare expression for returning.
12630 Like ffecom_prepare_expr, except for expressions to be evaluated
12631 via ffecom_return_expr. */
12634 ffecom_prepare_return_expr (ffebld expr
)
12636 assert (current_binding_level
->prep_state
< 2);
12638 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12639 && ffecom_is_altreturning_
12641 ffecom_prepare_expr (expr
);
12644 /* Prepare pointer to expression.
12646 Like ffecom_prepare_expr, except for expressions to be evaluated
12647 via ffecom_ptr_to_expr. */
12650 ffecom_prepare_ptr_to_expr (ffebld expr
)
12652 /* ~~For now, it seems to be the same thing. */
12653 ffecom_prepare_expr (expr
);
12657 /* Transform expression into constant pointer-to-expression tree.
12659 If the expression can be transformed into a pointer-to-expression tree
12660 that is constant, that is done, and the tree returned. Else NULL_TREE
12663 That way, a caller can attempt to provide compile-time initialization
12664 of a variable and, if that fails, *then* choose to start a new block
12665 and resort to using temporaries, as appropriate. */
12668 ffecom_ptr_to_const_expr (ffebld expr
)
12671 return integer_zero_node
;
12673 if (ffebld_op (expr
) == FFEBLD_opANY
)
12674 return error_mark_node
;
12676 if (ffebld_arity (expr
) == 0
12677 && (ffebld_op (expr
) != FFEBLD_opSYMTER
12678 || ffebld_where (expr
) == FFEINFO_whereCOMMON
12679 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
12680 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
12684 t
= ffecom_ptr_to_expr (expr
);
12685 assert (TREE_CONSTANT (t
));
12692 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12694 tree rtn; // NULL_TREE means use expand_null_return()
12695 ffebld expr; // NULL if no alt return expr to RETURN stmt
12696 rtn = ffecom_return_expr(expr);
12698 Based on the program unit type and other info (like return function
12699 type, return master function type when alternate ENTRY points,
12700 whether subroutine has any alternate RETURN points, etc), returns the
12701 appropriate expression to be returned to the caller, or NULL_TREE
12702 meaning no return value or the caller expects it to be returned somewhere
12703 else (which is handled by other parts of this module). */
12706 ffecom_return_expr (ffebld expr
)
12710 switch (ffecom_primary_entry_kind_
)
12712 case FFEINFO_kindPROGRAM
:
12713 case FFEINFO_kindBLOCKDATA
:
12717 case FFEINFO_kindSUBROUTINE
:
12718 if (!ffecom_is_altreturning_
)
12719 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
12720 else if (expr
== NULL
)
12721 rtn
= integer_zero_node
;
12723 rtn
= ffecom_expr (expr
);
12726 case FFEINFO_kindFUNCTION
:
12727 if ((ffecom_multi_retval_
!= NULL_TREE
)
12728 || (ffesymbol_basictype (ffecom_primary_entry_
)
12729 == FFEINFO_basictypeCHARACTER
)
12730 || ((ffesymbol_basictype (ffecom_primary_entry_
)
12731 == FFEINFO_basictypeCOMPLEX
)
12732 && (ffecom_num_entrypoints_
== 0)
12733 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
12734 { /* Value is returned by direct assignment
12735 into (implicit) dummy. */
12739 rtn
= ffecom_func_result_
;
12741 /* Spurious error if RETURN happens before first reference! So elide
12742 this code. In particular, for debugging registry, rtn should always
12743 be non-null after all, but TREE_USED won't be set until we encounter
12744 a reference in the code. Perfectly okay (but weird) code that,
12745 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12746 this diagnostic for no reason. Have people use -O -Wuninitialized
12747 and leave it to the back end to find obviously weird cases. */
12749 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12750 situation; if the return value has never been referenced, it won't
12751 have a tree under 2pass mode. */
12752 if ((rtn
== NULL_TREE
)
12753 || !TREE_USED (rtn
))
12755 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
12756 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
12757 ffesymbol_where_column (ffecom_primary_entry_
));
12758 ffebad_string (ffesymbol_text (ffesymbol_funcresult
12759 (ffecom_primary_entry_
)));
12766 assert ("bad unit kind" == NULL
);
12767 case FFEINFO_kindANY
:
12768 rtn
= error_mark_node
;
12775 /* Do save_expr only if tree is not error_mark_node. */
12778 ffecom_save_tree (tree t
)
12780 return save_expr (t
);
12783 /* Start a compound statement (block). */
12786 ffecom_start_compstmt (void)
12788 bison_rule_pushlevel_ ();
12791 /* Public entry point for front end to access start_decl. */
12794 ffecom_start_decl (tree decl
, bool is_initialized
)
12796 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
12797 return start_decl (decl
, FALSE
);
12800 /* ffecom_sym_commit -- Symbol's state being committed to reality
12803 ffecom_sym_commit(s);
12805 Does whatever the backend needs when a symbol is committed after having
12806 been backtrackable for a period of time. */
12809 ffecom_sym_commit (ffesymbol s UNUSED
)
12811 assert (!ffesymbol_retractable ());
12814 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12816 ffecom_sym_end_transition();
12818 Does backend-specific stuff and also calls ffest_sym_end_transition
12819 to do the necessary FFE stuff.
12821 Backtracking is never enabled when this fn is called, so don't worry
12825 ffecom_sym_end_transition (ffesymbol s
)
12829 assert (!ffesymbol_retractable ());
12831 s
= ffest_sym_end_transition (s
);
12833 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
12834 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
12836 ffecom_list_blockdata_
12837 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12838 FFEINTRIN_specNONE
,
12839 FFEINTRIN_impNONE
),
12840 ffecom_list_blockdata_
);
12843 /* This is where we finally notice that a symbol has partial initialization
12844 and finalize it. */
12846 if (ffesymbol_accretion (s
) != NULL
)
12848 assert (ffesymbol_init (s
) == NULL
);
12849 ffecom_notify_init_symbol (s
);
12851 else if (((st
= ffesymbol_storage (s
)) != NULL
)
12852 && ((st
= ffestorag_parent (st
)) != NULL
)
12853 && (ffestorag_accretion (st
) != NULL
))
12855 assert (ffestorag_init (st
) == NULL
);
12856 ffecom_notify_init_storage (st
);
12859 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
12860 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
12861 && (ffesymbol_storage (s
) != NULL
))
12863 ffecom_list_common_
12864 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12865 FFEINTRIN_specNONE
,
12866 FFEINTRIN_impNONE
),
12867 ffecom_list_common_
);
12873 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12875 ffecom_sym_exec_transition();
12877 Does backend-specific stuff and also calls ffest_sym_exec_transition
12878 to do the necessary FFE stuff.
12880 See the long-winded description in ffecom_sym_learned for info
12881 on handling the situation where backtracking is inhibited. */
12884 ffecom_sym_exec_transition (ffesymbol s
)
12886 s
= ffest_sym_exec_transition (s
);
12891 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12894 s = ffecom_sym_learned(s);
12896 Called when a new symbol is seen after the exec transition or when more
12897 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12898 it arrives here is that all its latest info is updated already, so its
12899 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12900 field filled in if its gone through here or exec_transition first, and
12903 The backend probably wants to check ffesymbol_retractable() to see if
12904 backtracking is in effect. If so, the FFE's changes to the symbol may
12905 be retracted (undone) or committed (ratified), at which time the
12906 appropriate ffecom_sym_retract or _commit function will be called
12909 If the backend has its own backtracking mechanism, great, use it so that
12910 committal is a simple operation. Though it doesn't make much difference,
12911 I suppose: the reason for tentative symbol evolution in the FFE is to
12912 enable error detection in weird incorrect statements early and to disable
12913 incorrect error detection on a correct statement. The backend is not
12914 likely to introduce any information that'll get involved in these
12915 considerations, so it is probably just fine that the implementation
12916 model for this fn and for _exec_transition is to not do anything
12917 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12918 and instead wait until ffecom_sym_commit is called (which it never
12919 will be as long as we're using ambiguity-detecting statement analysis in
12920 the FFE, which we are initially to shake out the code, but don't depend
12921 on this), otherwise go ahead and do whatever is needed.
12923 In essence, then, when this fn and _exec_transition get called while
12924 backtracking is enabled, a general mechanism would be to flag which (or
12925 both) of these were called (and in what order? neat question as to what
12926 might happen that I'm too lame to think through right now) and then when
12927 _commit is called reproduce the original calling sequence, if any, for
12928 the two fns (at which point backtracking will, of course, be disabled). */
12931 ffecom_sym_learned (ffesymbol s
)
12933 ffestorag_exec_layout (s
);
12938 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12941 ffecom_sym_retract(s);
12943 Does whatever the backend needs when a symbol is retracted after having
12944 been backtrackable for a period of time. */
12947 ffecom_sym_retract (ffesymbol s UNUSED
)
12949 assert (!ffesymbol_retractable ());
12951 #if 0 /* GCC doesn't commit any backtrackable sins,
12952 so nothing needed here. */
12953 switch (ffesymbol_hook (s
).state
)
12955 case 0: /* nothing happened yet. */
12958 case 1: /* exec transition happened. */
12961 case 2: /* learned happened. */
12964 case 3: /* learned then exec. */
12967 case 4: /* exec then learned. */
12971 assert ("bad hook state" == NULL
);
12977 /* Create temporary gcc label. */
12980 ffecom_temp_label ()
12983 static int mynumber
= 0;
12985 glabel
= build_decl (LABEL_DECL
,
12986 ffecom_get_invented_identifier ("__g77_label_%d",
12989 DECL_CONTEXT (glabel
) = current_function_decl
;
12990 DECL_MODE (glabel
) = VOIDmode
;
12995 /* Return an expression that is usable as an arg in a conditional context
12996 (IF, DO WHILE, .NOT., and so on).
12998 Use the one provided for the back end as of >2.6.0. */
13001 ffecom_truth_value (tree expr
)
13003 return truthvalue_conversion (expr
);
13006 /* Return the inversion of a truth value (the inversion of what
13007 ffecom_truth_value builds).
13009 Apparently invert_truthvalue, which is properly in the back end, is
13010 enough for now, so just use it. */
13013 ffecom_truth_value_invert (tree expr
)
13015 return invert_truthvalue (ffecom_truth_value (expr
));
13018 /* Return the tree that is the type of the expression, as would be
13019 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13020 transforming the expression, generating temporaries, etc. */
13023 ffecom_type_expr (ffebld expr
)
13025 ffeinfoBasictype bt
;
13026 ffeinfoKindtype kt
;
13029 assert (expr
!= NULL
);
13031 bt
= ffeinfo_basictype (ffebld_info (expr
));
13032 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13033 tree_type
= ffecom_tree_type
[bt
][kt
];
13035 switch (ffebld_op (expr
))
13037 case FFEBLD_opCONTER
:
13038 case FFEBLD_opSYMTER
:
13039 case FFEBLD_opARRAYREF
:
13040 case FFEBLD_opUPLUS
:
13041 case FFEBLD_opPAREN
:
13042 case FFEBLD_opUMINUS
:
13044 case FFEBLD_opSUBTRACT
:
13045 case FFEBLD_opMULTIPLY
:
13046 case FFEBLD_opDIVIDE
:
13047 case FFEBLD_opPOWER
:
13049 case FFEBLD_opFUNCREF
:
13050 case FFEBLD_opSUBRREF
:
13054 case FFEBLD_opNEQV
:
13056 case FFEBLD_opCONVERT
:
13063 case FFEBLD_opPERCENT_LOC
:
13066 case FFEBLD_opACCTER
:
13067 case FFEBLD_opARRTER
:
13068 case FFEBLD_opITEM
:
13069 case FFEBLD_opSTAR
:
13070 case FFEBLD_opBOUNDS
:
13071 case FFEBLD_opREPEAT
:
13072 case FFEBLD_opLABTER
:
13073 case FFEBLD_opLABTOK
:
13074 case FFEBLD_opIMPDO
:
13075 case FFEBLD_opCONCATENATE
:
13076 case FFEBLD_opSUBSTR
:
13078 assert ("bad op for ffecom_type_expr" == NULL
);
13079 /* Fall through. */
13081 return error_mark_node
;
13085 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13087 If the PARM_DECL already exists, return it, else create it. It's an
13088 integer_type_node argument for the master function that implements a
13089 subroutine or function with more than one entrypoint and is bound at
13090 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13091 first ENTRY statement, and so on). */
13094 ffecom_which_entrypoint_decl ()
13096 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13098 return ffecom_which_entrypoint_decl_
;
13101 /* The following sections consists of private and public functions
13102 that have the same names and perform roughly the same functions
13103 as counterparts in the C front end. Changes in the C front end
13104 might affect how things should be done here. Only functions
13105 needed by the back end should be public here; the rest should
13106 be private (static in the C sense). Functions needed by other
13107 g77 front-end modules should be accessed by them via public
13108 ffecom_* names, which should themselves call private versions
13109 in this section so the private versions are easy to recognize
13110 when upgrading to a new gcc and finding interesting changes
13113 Functions named after rule "foo:" in c-parse.y are named
13114 "bison_rule_foo_" so they are easy to find. */
13117 bison_rule_pushlevel_ ()
13119 emit_line_note (input_filename
, lineno
);
13121 clear_last_expr ();
13122 expand_start_bindings (0);
13126 bison_rule_compstmt_ ()
13129 int keep
= kept_level_p ();
13131 /* Make the temps go away. */
13133 current_binding_level
->names
= NULL_TREE
;
13135 emit_line_note (input_filename
, lineno
);
13136 expand_end_bindings (getdecls (), keep
, 0);
13137 t
= poplevel (keep
, 1, 0);
13142 /* Return a definition for a builtin function named NAME and whose data type
13143 is TYPE. TYPE should be a function type with argument types.
13144 FUNCTION_CODE tells later passes how to compile calls to this function.
13145 See tree.h for its possible values.
13147 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13148 the name to be called if we can't opencode the function. */
13151 builtin_function (const char *name
, tree type
, int function_code
,
13152 enum built_in_class
class,
13153 const char *library_name
)
13155 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13156 DECL_EXTERNAL (decl
) = 1;
13157 TREE_PUBLIC (decl
) = 1;
13159 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
13160 make_decl_rtl (decl
, NULL
);
13162 DECL_BUILT_IN_CLASS (decl
) = class;
13163 DECL_FUNCTION_CODE (decl
) = function_code
;
13168 /* Handle when a new declaration NEWDECL
13169 has the same name as an old one OLDDECL
13170 in the same binding contour.
13171 Prints an error message if appropriate.
13173 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13174 Otherwise, return 0. */
13177 duplicate_decls (tree newdecl
, tree olddecl
)
13179 int types_match
= 1;
13180 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13181 && DECL_INITIAL (newdecl
) != 0);
13182 tree oldtype
= TREE_TYPE (olddecl
);
13183 tree newtype
= TREE_TYPE (newdecl
);
13185 if (olddecl
== newdecl
)
13188 if (TREE_CODE (newtype
) == ERROR_MARK
13189 || TREE_CODE (oldtype
) == ERROR_MARK
)
13192 /* New decl is completely inconsistent with the old one =>
13193 tell caller to replace the old one.
13194 This is always an error except in the case of shadowing a builtin. */
13195 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13198 /* For real parm decl following a forward decl,
13199 return 1 so old decl will be reused. */
13200 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13201 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13204 /* The new declaration is the same kind of object as the old one.
13205 The declarations may partially match. Print warnings if they don't
13206 match enough. Ultimately, copy most of the information from the new
13207 decl to the old one, and keep using the old one. */
13209 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13210 && DECL_BUILT_IN (olddecl
))
13212 /* A function declaration for a built-in function. */
13213 if (!TREE_PUBLIC (newdecl
))
13215 else if (!types_match
)
13217 /* Accept the return type of the new declaration if same modes. */
13218 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13219 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13221 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13223 /* Function types may be shared, so we can't just modify
13224 the return type of olddecl's function type. */
13226 = build_function_type (newreturntype
,
13227 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13231 TREE_TYPE (olddecl
) = newtype
;
13237 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13238 && DECL_SOURCE_LINE (olddecl
) == 0)
13240 /* A function declaration for a predeclared function
13241 that isn't actually built in. */
13242 if (!TREE_PUBLIC (newdecl
))
13244 else if (!types_match
)
13246 /* If the types don't match, preserve volatility indication.
13247 Later on, we will discard everything else about the
13248 default declaration. */
13249 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13253 /* Copy all the DECL_... slots specified in the new decl
13254 except for any that we copy here from the old type.
13256 Past this point, we don't change OLDTYPE and NEWTYPE
13257 even if we change the types of NEWDECL and OLDDECL. */
13261 /* Merge the data types specified in the two decls. */
13262 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13263 TREE_TYPE (newdecl
)
13264 = TREE_TYPE (olddecl
)
13265 = TREE_TYPE (newdecl
);
13267 /* Lay the type out, unless already done. */
13268 if (oldtype
!= TREE_TYPE (newdecl
))
13270 if (TREE_TYPE (newdecl
) != error_mark_node
)
13271 layout_type (TREE_TYPE (newdecl
));
13272 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13273 && TREE_CODE (newdecl
) != TYPE_DECL
13274 && TREE_CODE (newdecl
) != CONST_DECL
)
13275 layout_decl (newdecl
, 0);
13279 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13280 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13281 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13282 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13283 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13285 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13286 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13290 /* Keep the old rtl since we can safely use it. */
13291 COPY_DECL_RTL (olddecl
, newdecl
);
13293 /* Merge the type qualifiers. */
13294 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13295 && !TREE_THIS_VOLATILE (newdecl
))
13296 TREE_THIS_VOLATILE (olddecl
) = 0;
13297 if (TREE_READONLY (newdecl
))
13298 TREE_READONLY (olddecl
) = 1;
13299 if (TREE_THIS_VOLATILE (newdecl
))
13301 TREE_THIS_VOLATILE (olddecl
) = 1;
13302 if (TREE_CODE (newdecl
) == VAR_DECL
)
13303 make_var_volatile (newdecl
);
13306 /* Keep source location of definition rather than declaration.
13307 Likewise, keep decl at outer scope. */
13308 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13309 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13311 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13312 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13314 if (DECL_CONTEXT (olddecl
) == 0
13315 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13316 DECL_CONTEXT (newdecl
) = 0;
13319 /* Merge the unused-warning information. */
13320 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13321 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13322 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13323 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13325 /* Merge the initialization information. */
13326 if (DECL_INITIAL (newdecl
) == 0)
13327 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13329 /* Merge the section attribute.
13330 We want to issue an error if the sections conflict but that must be
13331 done later in decl_attributes since we are called before attributes
13333 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13334 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13336 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13338 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13339 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13342 /* If cannot merge, then use the new type and qualifiers,
13343 and don't preserve the old rtl. */
13346 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13347 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13348 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13349 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13352 /* Merge the storage class information. */
13353 /* For functions, static overrides non-static. */
13354 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13356 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13357 /* This is since we don't automatically
13358 copy the attributes of NEWDECL into OLDDECL. */
13359 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13360 /* If this clears `static', clear it in the identifier too. */
13361 if (! TREE_PUBLIC (olddecl
))
13362 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13364 if (DECL_EXTERNAL (newdecl
))
13366 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13367 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13368 /* An extern decl does not override previous storage class. */
13369 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13373 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13374 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13377 /* If either decl says `inline', this fn is inline,
13378 unless its definition was passed already. */
13379 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13380 DECL_INLINE (olddecl
) = 1;
13381 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13383 /* Get rid of any built-in function if new arg types don't match it
13384 or if we have a function definition. */
13385 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13386 && DECL_BUILT_IN (olddecl
)
13387 && (!types_match
|| new_is_definition
))
13389 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13390 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13393 /* If redeclaring a builtin function, and not a definition,
13395 Also preserve various other info from the definition. */
13396 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13398 if (DECL_BUILT_IN (olddecl
))
13400 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13401 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13404 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13405 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13406 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13407 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13410 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13411 But preserve olddecl's DECL_UID. */
13413 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13415 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13416 (char *) newdecl
+ sizeof (struct tree_common
),
13417 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13418 DECL_UID (olddecl
) = olddecl_uid
;
13424 /* Finish processing of a declaration;
13425 install its initial value.
13426 If the length of an array type is not known before,
13427 it must be determined now, from the initial value, or it is an error. */
13430 finish_decl (tree decl
, tree init
, bool is_top_level
)
13432 register tree type
= TREE_TYPE (decl
);
13433 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13434 bool at_top_level
= (current_binding_level
== global_binding_level
);
13435 bool top_level
= is_top_level
|| at_top_level
;
13437 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13439 assert (!is_top_level
|| !at_top_level
);
13441 if (TREE_CODE (decl
) == PARM_DECL
)
13442 assert (init
== NULL_TREE
);
13443 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13444 overlaps DECL_ARG_TYPE. */
13445 else if (init
== NULL_TREE
)
13446 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13448 assert (DECL_INITIAL (decl
) == error_mark_node
);
13450 if (init
!= NULL_TREE
)
13452 if (TREE_CODE (decl
) != TYPE_DECL
)
13453 DECL_INITIAL (decl
) = init
;
13456 /* typedef foo = bar; store the type of bar as the type of foo. */
13457 TREE_TYPE (decl
) = TREE_TYPE (init
);
13458 DECL_INITIAL (decl
) = init
= 0;
13462 /* Deduce size of array from initialization, if not already known */
13464 if (TREE_CODE (type
) == ARRAY_TYPE
13465 && TYPE_DOMAIN (type
) == 0
13466 && TREE_CODE (decl
) != TYPE_DECL
)
13468 assert (top_level
);
13469 assert (was_incomplete
);
13471 layout_decl (decl
, 0);
13474 if (TREE_CODE (decl
) == VAR_DECL
)
13476 if (DECL_SIZE (decl
) == NULL_TREE
13477 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13478 layout_decl (decl
, 0);
13480 if (DECL_SIZE (decl
) == NULL_TREE
13481 && (TREE_STATIC (decl
)
13483 /* A static variable with an incomplete type is an error if it is
13484 initialized. Also if it is not file scope. Otherwise, let it
13485 through, but if it is not `extern' then it may cause an error
13487 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13489 /* An automatic variable with an incomplete type is an error. */
13490 !DECL_EXTERNAL (decl
)))
13492 assert ("storage size not known" == NULL
);
13496 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13497 && (DECL_SIZE (decl
) != 0)
13498 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13500 assert ("storage size not constant" == NULL
);
13505 /* Output the assembler code and/or RTL code for variables and functions,
13506 unless the type is an undefined structure or union. If not, it will get
13507 done when the type is completed. */
13509 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13511 rest_of_decl_compilation (decl
, NULL
,
13512 DECL_CONTEXT (decl
) == 0,
13515 if (DECL_CONTEXT (decl
) != 0)
13517 /* Recompute the RTL of a local array now if it used to be an
13518 incomplete type. */
13520 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13522 /* If we used it already as memory, it must stay in memory. */
13523 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13524 /* If it's still incomplete now, no init will save it. */
13525 if (DECL_SIZE (decl
) == 0)
13526 DECL_INITIAL (decl
) = 0;
13527 expand_decl (decl
);
13529 /* Compute and store the initial value. */
13530 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13531 expand_decl_init (decl
);
13534 else if (TREE_CODE (decl
) == TYPE_DECL
)
13536 rest_of_decl_compilation (decl
, NULL
,
13537 DECL_CONTEXT (decl
) == 0,
13541 /* At the end of a declaration, throw away any variable type sizes of types
13542 defined inside that declaration. There is no use computing them in the
13543 following function definition. */
13544 if (current_binding_level
== global_binding_level
)
13545 get_pending_sizes ();
13548 /* Finish up a function declaration and compile that function
13549 all the way to assembler language output. The free the storage
13550 for the function definition.
13552 This is called after parsing the body of the function definition.
13554 NESTED is nonzero if the function being finished is nested in another. */
13557 finish_function (int nested
)
13559 register tree fndecl
= current_function_decl
;
13561 assert (fndecl
!= NULL_TREE
);
13562 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13565 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13567 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13570 /* TREE_READONLY (fndecl) = 1;
13571 This caused &foo to be of type ptr-to-const-function
13572 which then got a warning when stored in a ptr-to-function variable. */
13574 poplevel (1, 0, 1);
13576 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13578 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13580 /* Must mark the RESULT_DECL as being in this function. */
13582 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13584 /* Obey `register' declarations if `setjmp' is called in this fn. */
13585 /* Generate rtl for function exit. */
13586 expand_function_end (input_filename
, lineno
, 0);
13588 /* If this is a nested function, protect the local variables in the stack
13589 above us from being collected while we're compiling this function. */
13591 ggc_push_context ();
13593 /* Run the optimizers and output the assembler code for this function. */
13594 rest_of_compilation (fndecl
);
13596 /* Undo the GC context switch. */
13598 ggc_pop_context ();
13601 if (TREE_CODE (fndecl
) != ERROR_MARK
13603 && DECL_SAVED_INSNS (fndecl
) == 0)
13605 /* Stop pointing to the local nodes about to be freed. */
13606 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13607 function definition. */
13608 /* For a nested function, this is done in pop_f_function_context. */
13609 /* If rest_of_compilation set this to 0, leave it 0. */
13610 if (DECL_INITIAL (fndecl
) != 0)
13611 DECL_INITIAL (fndecl
) = error_mark_node
;
13612 DECL_ARGUMENTS (fndecl
) = 0;
13617 /* Let the error reporting routines know that we're outside a function.
13618 For a nested function, this value is used in pop_c_function_context
13619 and then reset via pop_function_context. */
13620 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13624 /* Plug-in replacement for identifying the name of a decl and, for a
13625 function, what we call it in diagnostics. For now, "program unit"
13626 should suffice, since it's a bit of a hassle to figure out which
13627 of several kinds of things it is. Note that it could conceivably
13628 be a statement function, which probably isn't really a program unit
13629 per se, but if that comes up, it should be easy to check (being a
13630 nested function and all). */
13632 static const char *
13633 ffe_printable_name (tree decl
, int v
)
13635 /* Just to keep GCC quiet about the unused variable.
13636 In theory, differing values of V should produce different
13641 if (TREE_CODE (decl
) == ERROR_MARK
)
13642 return "erroneous code";
13643 return IDENTIFIER_POINTER (DECL_NAME (decl
));
13647 /* g77's function to print out name of current function that caused
13651 lang_print_error_function (diagnostic_context
*context
__attribute__((unused
)),
13654 static ffeglobal last_g
= NULL
;
13655 static ffesymbol last_s
= NULL
;
13660 if ((ffecom_primary_entry_
== NULL
)
13661 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
13669 g
= ffesymbol_global (ffecom_primary_entry_
);
13670 if (ffecom_nested_entry_
== NULL
)
13672 s
= ffecom_primary_entry_
;
13673 kind
= _(ffeinfo_kind_message (ffesymbol_kind (s
)));
13677 s
= ffecom_nested_entry_
;
13678 kind
= _("In statement function");
13682 if ((last_g
!= g
) || (last_s
!= s
))
13685 fprintf (stderr
, "%s: ", file
);
13688 fprintf (stderr
, _("Outside of any program unit:\n"));
13691 const char *name
= ffesymbol_text (s
);
13693 fprintf (stderr
, "%s `%s':\n", kind
, name
);
13701 /* Similar to `lookup_name' but look only at current binding level. */
13704 lookup_name_current_level (tree name
)
13708 if (current_binding_level
== global_binding_level
)
13709 return IDENTIFIER_GLOBAL_VALUE (name
);
13711 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
13714 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
13715 if (DECL_NAME (t
) == name
)
13721 /* Create a new `struct binding_level'. */
13723 static struct binding_level
*
13724 make_binding_level ()
13727 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
13730 /* Save and restore the variables in this file and elsewhere
13731 that keep track of the progress of compilation of the current function.
13732 Used for nested functions. */
13736 struct f_function
*next
;
13738 tree shadowed_labels
;
13739 struct binding_level
*binding_level
;
13742 struct f_function
*f_function_chain
;
13744 /* Restore the variables used during compilation of a C function. */
13747 pop_f_function_context ()
13749 struct f_function
*p
= f_function_chain
;
13752 /* Bring back all the labels that were shadowed. */
13753 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
13754 if (DECL_NAME (TREE_VALUE (link
)) != 0)
13755 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
13756 = TREE_VALUE (link
);
13758 if (current_function_decl
!= error_mark_node
13759 && DECL_SAVED_INSNS (current_function_decl
) == 0)
13761 /* Stop pointing to the local nodes about to be freed. */
13762 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13763 function definition. */
13764 DECL_INITIAL (current_function_decl
) = error_mark_node
;
13765 DECL_ARGUMENTS (current_function_decl
) = 0;
13768 pop_function_context ();
13770 f_function_chain
= p
->next
;
13772 named_labels
= p
->named_labels
;
13773 shadowed_labels
= p
->shadowed_labels
;
13774 current_binding_level
= p
->binding_level
;
13779 /* Save and reinitialize the variables
13780 used during compilation of a C function. */
13783 push_f_function_context ()
13785 struct f_function
*p
13786 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
13788 push_function_context ();
13790 p
->next
= f_function_chain
;
13791 f_function_chain
= p
;
13793 p
->named_labels
= named_labels
;
13794 p
->shadowed_labels
= shadowed_labels
;
13795 p
->binding_level
= current_binding_level
;
13799 push_parm_decl (tree parm
)
13801 int old_immediate_size_expand
= immediate_size_expand
;
13803 /* Don't try computing parm sizes now -- wait till fn is called. */
13805 immediate_size_expand
= 0;
13807 /* Fill in arg stuff. */
13809 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
13810 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
13811 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
13813 parm
= pushdecl (parm
);
13815 immediate_size_expand
= old_immediate_size_expand
;
13817 finish_decl (parm
, NULL_TREE
, FALSE
);
13820 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13823 pushdecl_top_level (x
)
13827 register struct binding_level
*b
= current_binding_level
;
13828 register tree f
= current_function_decl
;
13830 current_binding_level
= global_binding_level
;
13831 current_function_decl
= NULL_TREE
;
13833 current_binding_level
= b
;
13834 current_function_decl
= f
;
13838 /* Store the list of declarations of the current level.
13839 This is done for the parameter declarations of a function being defined,
13840 after they are modified in the light of any missing parameters. */
13846 return current_binding_level
->names
= decls
;
13849 /* Store the parameter declarations into the current function declaration.
13850 This is called after parsing the parameter declarations, before
13851 digesting the body of the function.
13853 For an old-style definition, modify the function's type
13854 to specify at least the number of arguments. */
13857 store_parm_decls (int is_main_program UNUSED
)
13859 register tree fndecl
= current_function_decl
;
13861 if (fndecl
== error_mark_node
)
13864 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13865 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
13867 /* Initialize the RTL code for the function. */
13869 init_function_start (fndecl
, input_filename
, lineno
);
13871 /* Set up parameters and prepare for return, for the function. */
13873 expand_function_start (fndecl
, 0);
13877 start_decl (tree decl
, bool is_top_level
)
13880 bool at_top_level
= (current_binding_level
== global_binding_level
);
13881 bool top_level
= is_top_level
|| at_top_level
;
13883 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13885 assert (!is_top_level
|| !at_top_level
);
13887 if (DECL_INITIAL (decl
) != NULL_TREE
)
13889 assert (DECL_INITIAL (decl
) == error_mark_node
);
13890 assert (!DECL_EXTERNAL (decl
));
13892 else if (top_level
)
13893 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
13895 /* For Fortran, we by default put things in .common when possible. */
13896 DECL_COMMON (decl
) = 1;
13898 /* Add this decl to the current binding level. TEM may equal DECL or it may
13899 be a previous decl of the same name. */
13901 tem
= pushdecl_top_level (decl
);
13903 tem
= pushdecl (decl
);
13905 /* For a local variable, define the RTL now. */
13907 /* But not if this is a duplicate decl and we preserved the rtl from the
13908 previous one (which may or may not happen). */
13909 && !DECL_RTL_SET_P (tem
))
13911 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
13913 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
13914 && DECL_INITIAL (tem
) != 0)
13921 /* Create the FUNCTION_DECL for a function definition.
13922 DECLSPECS and DECLARATOR are the parts of the declaration;
13923 they describe the function's name and the type it returns,
13924 but twisted together in a fashion that parallels the syntax of C.
13926 This function creates a binding context for the function body
13927 as well as setting up the FUNCTION_DECL in current_function_decl.
13929 Returns 1 on success. If the DECLARATOR is not suitable for a function
13930 (it defines a datum instead), we return 0, which tells
13931 ffe_parse_file to report a parse error.
13933 NESTED is nonzero for a function nested within another function. */
13936 start_function (tree name
, tree type
, int nested
, int public)
13940 int old_immediate_size_expand
= immediate_size_expand
;
13943 shadowed_labels
= 0;
13945 /* Don't expand any sizes in the return type of the function. */
13946 immediate_size_expand
= 0;
13951 assert (current_function_decl
!= NULL_TREE
);
13952 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
13956 assert (current_function_decl
== NULL_TREE
);
13959 if (TREE_CODE (type
) == ERROR_MARK
)
13960 decl1
= current_function_decl
= error_mark_node
;
13963 decl1
= build_decl (FUNCTION_DECL
,
13966 TREE_PUBLIC (decl1
) = public ? 1 : 0;
13968 DECL_INLINE (decl1
) = 1;
13969 TREE_STATIC (decl1
) = 1;
13970 DECL_EXTERNAL (decl1
) = 0;
13972 announce_function (decl1
);
13974 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13975 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13976 DECL_INITIAL (decl1
) = error_mark_node
;
13978 /* Record the decl so that the function name is defined. If we already have
13979 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13981 current_function_decl
= pushdecl (decl1
);
13985 ffecom_outer_function_decl_
= current_function_decl
;
13988 current_binding_level
->prep_state
= 2;
13990 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
13992 make_decl_rtl (current_function_decl
, NULL
);
13994 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
13995 DECL_RESULT (current_function_decl
)
13996 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
13999 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14000 TREE_ADDRESSABLE (current_function_decl
) = 1;
14002 immediate_size_expand
= old_immediate_size_expand
;
14005 /* Here are the public functions the GNU back end needs. */
14008 convert (type
, expr
)
14011 register tree e
= expr
;
14012 register enum tree_code code
= TREE_CODE (type
);
14014 if (type
== TREE_TYPE (e
)
14015 || TREE_CODE (e
) == ERROR_MARK
)
14017 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14018 return fold (build1 (NOP_EXPR
, type
, e
));
14019 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14020 || code
== ERROR_MARK
)
14021 return error_mark_node
;
14022 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14024 assert ("void value not ignored as it ought to be" == NULL
);
14025 return error_mark_node
;
14027 if (code
== VOID_TYPE
)
14028 return build1 (CONVERT_EXPR
, type
, e
);
14029 if ((code
!= RECORD_TYPE
)
14030 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14031 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14033 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14034 return fold (convert_to_integer (type
, e
));
14035 if (code
== POINTER_TYPE
)
14036 return fold (convert_to_pointer (type
, e
));
14037 if (code
== REAL_TYPE
)
14038 return fold (convert_to_real (type
, e
));
14039 if (code
== COMPLEX_TYPE
)
14040 return fold (convert_to_complex (type
, e
));
14041 if (code
== RECORD_TYPE
)
14042 return fold (ffecom_convert_to_complex_ (type
, e
));
14044 assert ("conversion to non-scalar type requested" == NULL
);
14045 return error_mark_node
;
14048 /* Return the list of declarations of the current level.
14049 Note that this list is in reverse order unless/until
14050 you nreverse it; and when you do nreverse it, you must
14051 store the result back using `storedecls' or you will lose. */
14056 return current_binding_level
->names
;
14059 /* Nonzero if we are currently in the global binding level. */
14062 global_bindings_p ()
14064 return current_binding_level
== global_binding_level
;
14067 /* Print an error message for invalid use of an incomplete type.
14068 VALUE is the expression that was used (or 0 if that isn't known)
14069 and TYPE is the type that was invalid. */
14072 incomplete_type_error (value
, type
)
14076 if (TREE_CODE (type
) == ERROR_MARK
)
14079 assert ("incomplete type?!?" == NULL
);
14082 /* Mark ARG for GC. */
14084 mark_binding_level (void *arg
)
14086 struct binding_level
*level
= *(struct binding_level
**) arg
;
14090 ggc_mark_tree (level
->names
);
14091 ggc_mark_tree (level
->blocks
);
14092 ggc_mark_tree (level
->this_block
);
14093 level
= level
->level_chain
;
14098 ffecom_init_decl_processing ()
14100 static tree
*const tree_roots
[] = {
14101 ¤t_function_decl
,
14103 &ffecom_tree_fun_type_void
,
14104 &ffecom_integer_zero_node
,
14105 &ffecom_integer_one_node
,
14106 &ffecom_tree_subr_type
,
14107 &ffecom_tree_ptr_to_subr_type
,
14108 &ffecom_tree_blockdata_type
,
14109 &ffecom_tree_xargc_
,
14110 &ffecom_f2c_integer_type_node
,
14111 &ffecom_f2c_ptr_to_integer_type_node
,
14112 &ffecom_f2c_address_type_node
,
14113 &ffecom_f2c_real_type_node
,
14114 &ffecom_f2c_ptr_to_real_type_node
,
14115 &ffecom_f2c_doublereal_type_node
,
14116 &ffecom_f2c_complex_type_node
,
14117 &ffecom_f2c_doublecomplex_type_node
,
14118 &ffecom_f2c_longint_type_node
,
14119 &ffecom_f2c_logical_type_node
,
14120 &ffecom_f2c_flag_type_node
,
14121 &ffecom_f2c_ftnlen_type_node
,
14122 &ffecom_f2c_ftnlen_zero_node
,
14123 &ffecom_f2c_ftnlen_one_node
,
14124 &ffecom_f2c_ftnlen_two_node
,
14125 &ffecom_f2c_ptr_to_ftnlen_type_node
,
14126 &ffecom_f2c_ftnint_type_node
,
14127 &ffecom_f2c_ptr_to_ftnint_type_node
,
14128 &ffecom_outer_function_decl_
,
14129 &ffecom_previous_function_decl_
,
14130 &ffecom_which_entrypoint_decl_
,
14131 &ffecom_float_zero_
,
14132 &ffecom_float_half_
,
14133 &ffecom_double_zero_
,
14134 &ffecom_double_half_
,
14135 &ffecom_func_result_
,
14136 &ffecom_func_length_
,
14137 &ffecom_multi_type_node_
,
14138 &ffecom_multi_retval_
,
14146 /* Record our roots. */
14147 for (i
= 0; i
< ARRAY_SIZE (tree_roots
); i
++)
14148 ggc_add_tree_root (tree_roots
[i
], 1);
14149 ggc_add_tree_root (&ffecom_tree_type
[0][0],
14150 FFEINFO_basictype
*FFEINFO_kindtype
);
14151 ggc_add_tree_root (&ffecom_tree_fun_type
[0][0],
14152 FFEINFO_basictype
*FFEINFO_kindtype
);
14153 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type
[0][0],
14154 FFEINFO_basictype
*FFEINFO_kindtype
);
14155 ggc_add_tree_root (ffecom_gfrt_
, FFECOM_gfrt
);
14156 ggc_add_root (¤t_binding_level
, 1, sizeof current_binding_level
,
14157 mark_binding_level
);
14158 ggc_add_root (&free_binding_level
, 1, sizeof current_binding_level
,
14159 mark_binding_level
);
14160 ggc_add_root (&tracker_head
, 1, sizeof tracker_head
, mark_tracker_head
);
14165 /* Delete the node BLOCK from the current binding level.
14166 This is used for the block inside a stmt expr ({...})
14167 so that the block can be reinserted where appropriate. */
14170 delete_block (block
)
14174 if (current_binding_level
->blocks
== block
)
14175 current_binding_level
->blocks
= TREE_CHAIN (block
);
14176 for (t
= current_binding_level
->blocks
; t
;)
14178 if (TREE_CHAIN (t
) == block
)
14179 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14181 t
= TREE_CHAIN (t
);
14183 TREE_CHAIN (block
) = NULL
;
14184 /* Clear TREE_USED which is always set by poplevel.
14185 The flag is set again if insert_block is called. */
14186 TREE_USED (block
) = 0;
14190 insert_block (block
)
14193 TREE_USED (block
) = 1;
14194 current_binding_level
->blocks
14195 = chainon (current_binding_level
->blocks
, block
);
14198 /* Each front end provides its own. */
14199 static const char *ffe_init
PARAMS ((const char *));
14200 static void ffe_finish
PARAMS ((void));
14201 static void ffe_init_options
PARAMS ((void));
14202 static void ffe_print_identifier
PARAMS ((FILE *, tree
, int));
14204 #undef LANG_HOOKS_NAME
14205 #define LANG_HOOKS_NAME "GNU F77"
14206 #undef LANG_HOOKS_INIT
14207 #define LANG_HOOKS_INIT ffe_init
14208 #undef LANG_HOOKS_FINISH
14209 #define LANG_HOOKS_FINISH ffe_finish
14210 #undef LANG_HOOKS_INIT_OPTIONS
14211 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14212 #undef LANG_HOOKS_DECODE_OPTION
14213 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14214 #undef LANG_HOOKS_PARSE_FILE
14215 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14216 #undef LANG_HOOKS_PRINT_IDENTIFIER
14217 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14218 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14219 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14221 /* We do not wish to use alias-set based aliasing at all. Used in the
14222 extreme (every object with its own set, with equivalences recorded) it
14223 might be helpful, but there are problems when it comes to inlining. We
14224 get on ok with flag_argument_noalias, and alias-set aliasing does
14225 currently limit how stack slots can be reused, which is a lose. */
14226 #undef LANG_HOOKS_GET_ALIAS_SET
14227 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14229 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
14231 /* Table indexed by tree code giving a string containing a character
14232 classifying the tree code. Possibilities are
14233 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14235 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14237 const char tree_code_type
[] = {
14238 #include "tree.def"
14242 /* Table indexed by tree code giving number of expression
14243 operands beyond the fixed part of the node structure.
14244 Not used for types or decls. */
14246 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14248 const unsigned char tree_code_length
[] = {
14249 #include "tree.def"
14253 /* Names of tree components.
14254 Used for printing out the tree and error messages. */
14255 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14257 const char *const tree_code_name
[] = {
14258 #include "tree.def"
14262 static const char *
14263 ffe_init (filename
)
14264 const char *filename
;
14266 /* Open input file. */
14267 if (filename
== 0 || !strcmp (filename
, "-"))
14270 filename
= "stdin";
14273 finput
= fopen (filename
, "r");
14275 fatal_io_error ("can't open %s", filename
);
14277 #ifdef IO_BUFFER_SIZE
14278 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14281 ffecom_init_decl_processing ();
14282 print_error_function
= lang_print_error_function
;
14284 /* If the file is output from cpp, it should contain a first line
14285 `# 1 "real-filename"', and the current design of gcc (toplev.c
14286 in particular and the way it sets up information relied on by
14287 INCLUDE) requires that we read this now, and store the
14288 "real-filename" info in master_input_filename. Ask the lexer
14289 to try doing this. */
14290 ffelex_hash_kludge (finput
);
14292 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14293 return the new file name. */
14294 if (main_input_filename
)
14295 filename
= main_input_filename
;
14303 ffe_terminate_0 ();
14305 if (ffe_is_ffedebug ())
14306 malloc_pool_display (malloc_pool_image ());
14312 ffe_init_options ()
14314 /* Set default options for Fortran. */
14315 flag_move_all_movables
= 1;
14316 flag_reduce_all_givs
= 1;
14317 flag_argument_noalias
= 2;
14318 flag_merge_constants
= 2;
14319 flag_errno_math
= 0;
14320 flag_complex_divide_method
= 1;
14324 mark_addressable (exp
)
14327 register tree x
= exp
;
14329 switch (TREE_CODE (x
))
14332 case COMPONENT_REF
:
14334 x
= TREE_OPERAND (x
, 0);
14338 TREE_ADDRESSABLE (x
) = 1;
14345 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14346 && DECL_NONLOCAL (x
))
14348 if (TREE_PUBLIC (x
))
14350 assert ("address of global register var requested" == NULL
);
14353 assert ("address of register variable requested" == NULL
);
14355 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14357 if (TREE_PUBLIC (x
))
14359 assert ("address of global register var requested" == NULL
);
14362 assert ("address of register var requested" == NULL
);
14364 put_var_into_stack (x
);
14367 case FUNCTION_DECL
:
14368 TREE_ADDRESSABLE (x
) = 1;
14369 #if 0 /* poplevel deals with this now. */
14370 if (DECL_CONTEXT (x
) == 0)
14371 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14379 /* If DECL has a cleanup, build and return that cleanup here.
14380 This is a callback called by expand_expr. */
14383 maybe_build_cleanup (decl
)
14386 /* There are no cleanups in Fortran. */
14390 /* Exit a binding level.
14391 Pop the level off, and restore the state of the identifier-decl mappings
14392 that were in effect when this level was entered.
14394 If KEEP is nonzero, this level had explicit declarations, so
14395 and create a "block" (a BLOCK node) for the level
14396 to record its declarations and subblocks for symbol table output.
14398 If FUNCTIONBODY is nonzero, this level is the body of a function,
14399 so create a block as if KEEP were set and also clear out all
14402 If REVERSE is nonzero, reverse the order of decls before putting
14403 them into the BLOCK. */
14406 poplevel (keep
, reverse
, functionbody
)
14411 register tree link
;
14412 /* The chain of decls was accumulated in reverse order.
14413 Put it into forward order, just for cleanliness. */
14415 tree subblocks
= current_binding_level
->blocks
;
14418 int block_previously_created
;
14420 /* Get the decls in the order they were written.
14421 Usually current_binding_level->names is in reverse order.
14422 But parameter decls were previously put in forward order. */
14425 current_binding_level
->names
14426 = decls
= nreverse (current_binding_level
->names
);
14428 decls
= current_binding_level
->names
;
14430 /* Output any nested inline functions within this block
14431 if they weren't already output. */
14433 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14434 if (TREE_CODE (decl
) == FUNCTION_DECL
14435 && ! TREE_ASM_WRITTEN (decl
)
14436 && DECL_INITIAL (decl
) != 0
14437 && TREE_ADDRESSABLE (decl
))
14439 /* If this decl was copied from a file-scope decl
14440 on account of a block-scope extern decl,
14441 propagate TREE_ADDRESSABLE to the file-scope decl.
14443 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14444 true, since then the decl goes through save_for_inline_copying. */
14445 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14446 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14447 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14448 else if (DECL_SAVED_INSNS (decl
) != 0)
14450 push_function_context ();
14451 output_inline_function (decl
);
14452 pop_function_context ();
14456 /* If there were any declarations or structure tags in that level,
14457 or if this level is a function body,
14458 create a BLOCK to record them for the life of this function. */
14461 block_previously_created
= (current_binding_level
->this_block
!= 0);
14462 if (block_previously_created
)
14463 block
= current_binding_level
->this_block
;
14464 else if (keep
|| functionbody
)
14465 block
= make_node (BLOCK
);
14468 BLOCK_VARS (block
) = decls
;
14469 BLOCK_SUBBLOCKS (block
) = subblocks
;
14472 /* In each subblock, record that this is its superior. */
14474 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14475 BLOCK_SUPERCONTEXT (link
) = block
;
14477 /* Clear out the meanings of the local variables of this level. */
14479 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14481 if (DECL_NAME (link
) != 0)
14483 /* If the ident. was used or addressed via a local extern decl,
14484 don't forget that fact. */
14485 if (DECL_EXTERNAL (link
))
14487 if (TREE_USED (link
))
14488 TREE_USED (DECL_NAME (link
)) = 1;
14489 if (TREE_ADDRESSABLE (link
))
14490 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14492 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14496 /* If the level being exited is the top level of a function,
14497 check over all the labels, and clear out the current
14498 (function local) meanings of their names. */
14502 /* If this is the top level block of a function,
14503 the vars are the function's parameters.
14504 Don't leave them in the BLOCK because they are
14505 found in the FUNCTION_DECL instead. */
14507 BLOCK_VARS (block
) = 0;
14510 /* Pop the current level, and free the structure for reuse. */
14513 register struct binding_level
*level
= current_binding_level
;
14514 current_binding_level
= current_binding_level
->level_chain
;
14516 level
->level_chain
= free_binding_level
;
14517 free_binding_level
= level
;
14520 /* Dispose of the block that we just made inside some higher level. */
14522 && current_function_decl
!= error_mark_node
)
14523 DECL_INITIAL (current_function_decl
) = block
;
14526 if (!block_previously_created
)
14527 current_binding_level
->blocks
14528 = chainon (current_binding_level
->blocks
, block
);
14530 /* If we did not make a block for the level just exited,
14531 any blocks made for inner levels
14532 (since they cannot be recorded as subblocks in that level)
14533 must be carried forward so they will later become subblocks
14534 of something else. */
14535 else if (subblocks
)
14536 current_binding_level
->blocks
14537 = chainon (current_binding_level
->blocks
, subblocks
);
14540 TREE_USED (block
) = 1;
14545 ffe_print_identifier (file
, node
, indent
)
14550 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14551 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14554 /* Record a decl-node X as belonging to the current lexical scope.
14555 Check for errors (such as an incompatible declaration for the same
14556 name already seen in the same scope).
14558 Returns either X or an old decl for the same name.
14559 If an old decl is returned, it may have been smashed
14560 to agree with what X says. */
14567 register tree name
= DECL_NAME (x
);
14568 register struct binding_level
*b
= current_binding_level
;
14570 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14571 && (DECL_INITIAL (x
) == 0)
14572 && DECL_EXTERNAL (x
))
14573 DECL_CONTEXT (x
) = NULL_TREE
;
14575 DECL_CONTEXT (x
) = current_function_decl
;
14579 if (IDENTIFIER_INVENTED (name
))
14581 DECL_ARTIFICIAL (x
) = 1;
14582 DECL_IN_SYSTEM_HEADER (x
) = 1;
14585 t
= lookup_name_current_level (name
);
14587 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14589 /* Don't push non-parms onto list for parms until we understand
14590 why we're doing this and whether it works. */
14592 assert ((b
== global_binding_level
)
14593 || !ffecom_transform_only_dummies_
14594 || TREE_CODE (x
) == PARM_DECL
);
14596 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
14599 /* If we are processing a typedef statement, generate a whole new
14600 ..._TYPE node (which will be just an variant of the existing
14601 ..._TYPE node with identical properties) and then install the
14602 TYPE_DECL node generated to represent the typedef name as the
14603 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14605 The whole point here is to end up with a situation where each and every
14606 ..._TYPE node the compiler creates will be uniquely associated with
14607 AT MOST one node representing a typedef name. This way, even though
14608 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14609 (i.e. "typedef name") nodes very early on, later parts of the
14610 compiler can always do the reverse translation and get back the
14611 corresponding typedef name. For example, given:
14613 typedef struct S MY_TYPE; MY_TYPE object;
14615 Later parts of the compiler might only know that `object' was of type
14616 `struct S' if it were not for code just below. With this code
14617 however, later parts of the compiler see something like:
14619 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14621 And they can then deduce (from the node for type struct S') that the
14622 original object declaration was:
14626 Being able to do this is important for proper support of protoize, and
14627 also for generating precise symbolic debugging information which
14628 takes full account of the programmer's (typedef) vocabulary.
14630 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14631 TYPE_DECL node that we are now processing really represents a
14632 standard built-in type.
14634 Since all standard types are effectively declared at line zero in the
14635 source file, we can easily check to see if we are working on a
14636 standard type by checking the current value of lineno. */
14638 if (TREE_CODE (x
) == TYPE_DECL
)
14640 if (DECL_SOURCE_LINE (x
) == 0)
14642 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
14643 TYPE_NAME (TREE_TYPE (x
)) = x
;
14645 else if (TREE_TYPE (x
) != error_mark_node
)
14647 tree tt
= TREE_TYPE (x
);
14649 tt
= build_type_copy (tt
);
14650 TYPE_NAME (tt
) = x
;
14651 TREE_TYPE (x
) = tt
;
14655 /* This name is new in its binding level. Install the new declaration
14657 if (b
== global_binding_level
)
14658 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
14660 IDENTIFIER_LOCAL_VALUE (name
) = x
;
14663 /* Put decls on list in reverse order. We will reverse them later if
14665 TREE_CHAIN (x
) = b
->names
;
14671 /* Nonzero if the current level needs to have a BLOCK made. */
14678 for (decl
= current_binding_level
->names
;
14680 decl
= TREE_CHAIN (decl
))
14682 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
14683 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
14684 /* Currently, there aren't supposed to be non-artificial names
14685 at other than the top block for a function -- they're
14686 believed to always be temps. But it's wise to check anyway. */
14692 /* Enter a new binding level.
14693 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14694 not for that of tags. */
14697 pushlevel (tag_transparent
)
14698 int tag_transparent
;
14700 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
14702 assert (! tag_transparent
);
14704 if (current_binding_level
== global_binding_level
)
14709 /* Reuse or create a struct for this binding level. */
14711 if (free_binding_level
)
14713 newlevel
= free_binding_level
;
14714 free_binding_level
= free_binding_level
->level_chain
;
14718 newlevel
= make_binding_level ();
14721 /* Add this level to the front of the chain (stack) of levels that
14724 *newlevel
= clear_binding_level
;
14725 newlevel
->level_chain
= current_binding_level
;
14726 current_binding_level
= newlevel
;
14729 /* Set the BLOCK node for the innermost scope
14730 (the one we are currently in). */
14734 register tree block
;
14736 current_binding_level
->this_block
= block
;
14737 current_binding_level
->names
= chainon (current_binding_level
->names
,
14738 BLOCK_VARS (block
));
14739 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
14740 BLOCK_SUBBLOCKS (block
));
14744 signed_or_unsigned_type (unsignedp
, type
)
14750 if (! INTEGRAL_TYPE_P (type
))
14752 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
14753 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14754 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
14755 return unsignedp
? unsigned_type_node
: integer_type_node
;
14756 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
14757 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14758 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
14759 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14760 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
14761 return (unsignedp
? long_long_unsigned_type_node
14762 : long_long_integer_type_node
);
14764 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
14765 if (type2
== NULL_TREE
)
14775 tree type1
= TYPE_MAIN_VARIANT (type
);
14776 ffeinfoKindtype kt
;
14779 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
14780 return signed_char_type_node
;
14781 if (type1
== unsigned_type_node
)
14782 return integer_type_node
;
14783 if (type1
== short_unsigned_type_node
)
14784 return short_integer_type_node
;
14785 if (type1
== long_unsigned_type_node
)
14786 return long_integer_type_node
;
14787 if (type1
== long_long_unsigned_type_node
)
14788 return long_long_integer_type_node
;
14789 #if 0 /* gcc/c-* files only */
14790 if (type1
== unsigned_intDI_type_node
)
14791 return intDI_type_node
;
14792 if (type1
== unsigned_intSI_type_node
)
14793 return intSI_type_node
;
14794 if (type1
== unsigned_intHI_type_node
)
14795 return intHI_type_node
;
14796 if (type1
== unsigned_intQI_type_node
)
14797 return intQI_type_node
;
14800 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
14801 if (type2
!= NULL_TREE
)
14804 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14806 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14808 if (type1
== type2
)
14809 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14815 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14816 or validate its data type for an `if' or `while' statement or ?..: exp.
14818 This preparation consists of taking the ordinary
14819 representation of an expression expr and producing a valid tree
14820 boolean expression describing whether expr is nonzero. We could
14821 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14822 but we optimize comparisons, &&, ||, and !.
14824 The resulting type should always be `integer_type_node'. */
14827 truthvalue_conversion (expr
)
14830 if (TREE_CODE (expr
) == ERROR_MARK
)
14833 #if 0 /* This appears to be wrong for C++. */
14834 /* These really should return error_mark_node after 2.4 is stable.
14835 But not all callers handle ERROR_MARK properly. */
14836 switch (TREE_CODE (TREE_TYPE (expr
)))
14839 error ("struct type value used where scalar is required");
14840 return integer_zero_node
;
14843 error ("union type value used where scalar is required");
14844 return integer_zero_node
;
14847 error ("array type value used where scalar is required");
14848 return integer_zero_node
;
14855 switch (TREE_CODE (expr
))
14857 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14858 or comparison expressions as truth values at this level. */
14860 case COMPONENT_REF
:
14861 /* A one-bit unsigned bit-field is already acceptable. */
14862 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
14863 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
14869 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14870 or comparison expressions as truth values at this level. */
14872 if (integer_zerop (TREE_OPERAND (expr
, 1)))
14873 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
14875 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
14876 case TRUTH_ANDIF_EXPR
:
14877 case TRUTH_ORIF_EXPR
:
14878 case TRUTH_AND_EXPR
:
14879 case TRUTH_OR_EXPR
:
14880 case TRUTH_XOR_EXPR
:
14881 TREE_TYPE (expr
) = integer_type_node
;
14888 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14891 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14894 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
14895 return build (COMPOUND_EXPR
, integer_type_node
,
14896 TREE_OPERAND (expr
, 0), integer_one_node
);
14898 return integer_one_node
;
14901 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
14902 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14904 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
14905 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
14911 /* These don't change whether an object is non-zero or zero. */
14912 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14916 /* These don't change whether an object is zero or non-zero, but
14917 we can't ignore them if their second arg has side-effects. */
14918 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
14919 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
14920 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
14922 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14925 /* Distribute the conversion into the arms of a COND_EXPR. */
14926 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
14927 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
14928 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
14931 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14932 since that affects how `default_conversion' will behave. */
14933 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
14934 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
14936 /* fall through... */
14938 /* If this is widening the argument, we can ignore it. */
14939 if (TYPE_PRECISION (TREE_TYPE (expr
))
14940 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
14941 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14945 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14947 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
14948 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
14950 /* fall through... */
14952 /* This and MINUS_EXPR can be changed into a comparison of the
14954 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
14955 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
14956 return ffecom_2 (NE_EXPR
, integer_type_node
,
14957 TREE_OPERAND (expr
, 0),
14958 TREE_OPERAND (expr
, 1));
14959 return ffecom_2 (NE_EXPR
, integer_type_node
,
14960 TREE_OPERAND (expr
, 0),
14961 fold (build1 (NOP_EXPR
,
14962 TREE_TYPE (TREE_OPERAND (expr
, 0)),
14963 TREE_OPERAND (expr
, 1))));
14966 if (integer_onep (TREE_OPERAND (expr
, 1)))
14971 #if 0 /* No such thing in Fortran. */
14972 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
14973 warning ("suggest parentheses around assignment used as truth value");
14981 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
14983 ((TREE_SIDE_EFFECTS (expr
)
14984 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14986 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
14987 TREE_TYPE (TREE_TYPE (expr
)),
14989 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
14990 TREE_TYPE (TREE_TYPE (expr
)),
14993 return ffecom_2 (NE_EXPR
, integer_type_node
,
14995 convert (TREE_TYPE (expr
), integer_zero_node
));
14999 type_for_mode (mode
, unsignedp
)
15000 enum machine_mode mode
;
15007 if (mode
== TYPE_MODE (integer_type_node
))
15008 return unsignedp
? unsigned_type_node
: integer_type_node
;
15010 if (mode
== TYPE_MODE (signed_char_type_node
))
15011 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15013 if (mode
== TYPE_MODE (short_integer_type_node
))
15014 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15016 if (mode
== TYPE_MODE (long_integer_type_node
))
15017 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15019 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15020 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15022 #if HOST_BITS_PER_WIDE_INT >= 64
15023 if (mode
== TYPE_MODE (intTI_type_node
))
15024 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
15027 if (mode
== TYPE_MODE (float_type_node
))
15028 return float_type_node
;
15030 if (mode
== TYPE_MODE (double_type_node
))
15031 return double_type_node
;
15033 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15034 return build_pointer_type (char_type_node
);
15036 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15037 return build_pointer_type (integer_type_node
);
15039 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15040 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15042 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15043 && (mode
== TYPE_MODE (t
)))
15045 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15046 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15056 type_for_size (bits
, unsignedp
)
15060 ffeinfoKindtype kt
;
15063 if (bits
== TYPE_PRECISION (integer_type_node
))
15064 return unsignedp
? unsigned_type_node
: integer_type_node
;
15066 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15067 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15069 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15070 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15072 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15073 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15075 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15076 return (unsignedp
? long_long_unsigned_type_node
15077 : long_long_integer_type_node
);
15079 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15081 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15083 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15084 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15092 unsigned_type (type
)
15095 tree type1
= TYPE_MAIN_VARIANT (type
);
15096 ffeinfoKindtype kt
;
15099 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15100 return unsigned_char_type_node
;
15101 if (type1
== integer_type_node
)
15102 return unsigned_type_node
;
15103 if (type1
== short_integer_type_node
)
15104 return short_unsigned_type_node
;
15105 if (type1
== long_integer_type_node
)
15106 return long_unsigned_type_node
;
15107 if (type1
== long_long_integer_type_node
)
15108 return long_long_unsigned_type_node
;
15109 #if 0 /* gcc/c-* files only */
15110 if (type1
== intDI_type_node
)
15111 return unsigned_intDI_type_node
;
15112 if (type1
== intSI_type_node
)
15113 return unsigned_intSI_type_node
;
15114 if (type1
== intHI_type_node
)
15115 return unsigned_intHI_type_node
;
15116 if (type1
== intQI_type_node
)
15117 return unsigned_intQI_type_node
;
15120 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15121 if (type2
!= NULL_TREE
)
15124 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15126 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15128 if (type1
== type2
)
15129 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15137 union tree_node
*t ATTRIBUTE_UNUSED
;
15139 if (TREE_CODE (t
) == IDENTIFIER_NODE
)
15141 struct lang_identifier
*i
= (struct lang_identifier
*) t
;
15142 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i
));
15143 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i
));
15144 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i
));
15146 else if (TYPE_P (t
) && TYPE_LANG_SPECIFIC (t
))
15147 ggc_mark (TYPE_LANG_SPECIFIC (t
));
15150 /* From gcc/cccp.c, the code to handle -I. */
15152 /* Skip leading "./" from a directory name.
15153 This may yield the empty string, which represents the current directory. */
15155 static const char *
15156 skip_redundant_dir_prefix (const char *dir
)
15158 while (dir
[0] == '.' && dir
[1] == '/')
15159 for (dir
+= 2; *dir
== '/'; dir
++)
15161 if (dir
[0] == '.' && !dir
[1])
15166 /* The file_name_map structure holds a mapping of file names for a
15167 particular directory. This mapping is read from the file named
15168 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15169 map filenames on a file system with severe filename restrictions,
15170 such as DOS. The format of the file name map file is just a series
15171 of lines with two tokens on each line. The first token is the name
15172 to map, and the second token is the actual name to use. */
15174 struct file_name_map
15176 struct file_name_map
*map_next
;
15181 #define FILE_NAME_MAP_FILE "header.gcc"
15183 /* Current maximum length of directory names in the search path
15184 for include files. (Altered as we get more of them.) */
15186 static int max_include_len
= 0;
15188 struct file_name_list
15190 struct file_name_list
*next
;
15192 /* Mapping of file names for this directory. */
15193 struct file_name_map
*name_map
;
15194 /* Non-zero if name_map is valid. */
15198 static struct file_name_list
*include
= NULL
; /* First dir to search */
15199 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15201 /* I/O buffer structure.
15202 The `fname' field is nonzero for source files and #include files
15203 and for the dummy text used for -D and -U.
15204 It is zero for rescanning results of macro expansion
15205 and for expanding macro arguments. */
15206 #define INPUT_STACK_MAX 400
15207 static struct file_buf
{
15209 /* Filename specified with #line command. */
15210 const char *nominal_fname
;
15211 /* Record where in the search path this file was found.
15212 For #include_next. */
15213 struct file_name_list
*dir
;
15215 ffewhereColumn column
;
15216 } instack
[INPUT_STACK_MAX
];
15218 static int last_error_tick
= 0; /* Incremented each time we print it. */
15219 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15221 /* Current nesting level of input sources.
15222 `instack[indepth]' is the level currently being read. */
15223 static int indepth
= -1;
15225 typedef struct file_buf FILE_BUF
;
15227 /* Nonzero means -I- has been seen,
15228 so don't look for #include "foo" the source-file directory. */
15229 static int ignore_srcdir
;
15231 #ifndef INCLUDE_LEN_FUDGE
15232 #define INCLUDE_LEN_FUDGE 0
15235 static void append_include_chain (struct file_name_list
*first
,
15236 struct file_name_list
*last
);
15237 static FILE *open_include_file (char *filename
,
15238 struct file_name_list
*searchptr
);
15239 static void print_containing_files (ffebadSeverity sev
);
15240 static char *read_filename_string (int ch
, FILE *f
);
15241 static struct file_name_map
*read_name_map (const char *dirname
);
15243 /* Append a chain of `struct file_name_list's
15244 to the end of the main include chain.
15245 FIRST is the beginning of the chain to append, and LAST is the end. */
15248 append_include_chain (first
, last
)
15249 struct file_name_list
*first
, *last
;
15251 struct file_name_list
*dir
;
15253 if (!first
|| !last
)
15259 last_include
->next
= first
;
15261 for (dir
= first
; ; dir
= dir
->next
) {
15262 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15263 if (len
> max_include_len
)
15264 max_include_len
= len
;
15270 last_include
= last
;
15273 /* Try to open include file FILENAME. SEARCHPTR is the directory
15274 being tried from the include file search path. This function maps
15275 filenames on file systems based on information read by
15279 open_include_file (filename
, searchptr
)
15281 struct file_name_list
*searchptr
;
15283 register struct file_name_map
*map
;
15284 register char *from
;
15287 if (searchptr
&& ! searchptr
->got_name_map
)
15289 searchptr
->name_map
= read_name_map (searchptr
->fname
15290 ? searchptr
->fname
: ".");
15291 searchptr
->got_name_map
= 1;
15294 /* First check the mapping for the directory we are using. */
15295 if (searchptr
&& searchptr
->name_map
)
15298 if (searchptr
->fname
)
15299 from
+= strlen (searchptr
->fname
) + 1;
15300 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15302 if (! strcmp (map
->map_from
, from
))
15304 /* Found a match. */
15305 return fopen (map
->map_to
, "r");
15310 /* Try to find a mapping file for the particular directory we are
15311 looking in. Thus #include <sys/types.h> will look up sys/types.h
15312 in /usr/include/header.gcc and look up types.h in
15313 /usr/include/sys/header.gcc. */
15314 p
= strrchr (filename
, '/');
15315 #ifdef DIR_SEPARATOR
15316 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15318 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15319 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15325 && searchptr
->fname
15326 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15327 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15329 /* FILENAME is in SEARCHPTR, which we've already checked. */
15330 return fopen (filename
, "r");
15336 map
= read_name_map (".");
15340 dir
= (char *) xmalloc (p
- filename
+ 1);
15341 memcpy (dir
, filename
, p
- filename
);
15342 dir
[p
- filename
] = '\0';
15344 map
= read_name_map (dir
);
15347 for (; map
; map
= map
->map_next
)
15348 if (! strcmp (map
->map_from
, from
))
15349 return fopen (map
->map_to
, "r");
15351 return fopen (filename
, "r");
15354 /* Print the file names and line numbers of the #include
15355 commands which led to the current file. */
15358 print_containing_files (ffebadSeverity sev
)
15360 FILE_BUF
*ip
= NULL
;
15366 /* If stack of files hasn't changed since we last printed
15367 this info, don't repeat it. */
15368 if (last_error_tick
== input_file_stack_tick
)
15371 for (i
= indepth
; i
>= 0; i
--)
15372 if (instack
[i
].fname
!= NULL
) {
15377 /* Give up if we don't find a source file. */
15381 /* Find the other, outer source files. */
15382 for (i
--; i
>= 0; i
--)
15383 if (instack
[i
].fname
!= NULL
)
15389 str1
= "In file included";
15401 /* xgettext:no-c-format */
15402 ffebad_start_msg ("%A from %B at %0%C", sev
);
15403 ffebad_here (0, ip
->line
, ip
->column
);
15404 ffebad_string (str1
);
15405 ffebad_string (ip
->nominal_fname
);
15406 ffebad_string (str2
);
15410 /* Record we have printed the status as of this time. */
15411 last_error_tick
= input_file_stack_tick
;
15414 /* Read a space delimited string of unlimited length from a stdio
15418 read_filename_string (ch
, f
)
15426 set
= alloc
= xmalloc (len
+ 1);
15427 if (! ISSPACE (ch
))
15430 while ((ch
= getc (f
)) != EOF
&& ! ISSPACE (ch
))
15432 if (set
- alloc
== len
)
15435 alloc
= xrealloc (alloc
, len
+ 1);
15436 set
= alloc
+ len
/ 2;
15446 /* Read the file name map file for DIRNAME. */
15448 static struct file_name_map
*
15449 read_name_map (dirname
)
15450 const char *dirname
;
15452 /* This structure holds a linked list of file name maps, one per
15454 struct file_name_map_list
15456 struct file_name_map_list
*map_list_next
;
15457 char *map_list_name
;
15458 struct file_name_map
*map_list_map
;
15460 static struct file_name_map_list
*map_list
;
15461 register struct file_name_map_list
*map_list_ptr
;
15465 int separator_needed
;
15467 dirname
= skip_redundant_dir_prefix (dirname
);
15469 for (map_list_ptr
= map_list
; map_list_ptr
;
15470 map_list_ptr
= map_list_ptr
->map_list_next
)
15471 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15472 return map_list_ptr
->map_list_map
;
15474 map_list_ptr
= ((struct file_name_map_list
*)
15475 xmalloc (sizeof (struct file_name_map_list
)));
15476 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15477 map_list_ptr
->map_list_map
= NULL
;
15479 dirlen
= strlen (dirname
);
15480 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15481 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
15482 strcpy (name
, dirname
);
15483 name
[dirlen
] = '/';
15484 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
15485 f
= fopen (name
, "r");
15488 map_list_ptr
->map_list_map
= NULL
;
15493 while ((ch
= getc (f
)) != EOF
)
15496 struct file_name_map
*ptr
;
15500 from
= read_filename_string (ch
, f
);
15501 while ((ch
= getc (f
)) != EOF
&& ISSPACE (ch
) && ch
!= '\n')
15503 to
= read_filename_string (ch
, f
);
15505 ptr
= ((struct file_name_map
*)
15506 xmalloc (sizeof (struct file_name_map
)));
15507 ptr
->map_from
= from
;
15509 /* Make the real filename absolute. */
15514 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
15515 strcpy (ptr
->map_to
, dirname
);
15516 ptr
->map_to
[dirlen
] = '/';
15517 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
15521 ptr
->map_next
= map_list_ptr
->map_list_map
;
15522 map_list_ptr
->map_list_map
= ptr
;
15524 while ((ch
= getc (f
)) != '\n')
15531 map_list_ptr
->map_list_next
= map_list
;
15532 map_list
= map_list_ptr
;
15534 return map_list_ptr
->map_list_map
;
15538 ffecom_file_ (const char *name
)
15542 /* Do partial setup of input buffer for the sake of generating
15543 early #line directives (when -g is in effect). */
15545 fp
= &instack
[++indepth
];
15546 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15549 fp
->nominal_fname
= fp
->fname
= name
;
15553 ffecom_close_include_ (FILE *f
)
15558 input_file_stack_tick
++;
15560 ffewhere_line_kill (instack
[indepth
].line
);
15561 ffewhere_column_kill (instack
[indepth
].column
);
15565 ffecom_decode_include_option_ (char *spec
)
15567 struct file_name_list
*dirtmp
;
15569 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
15573 dirtmp
= (struct file_name_list
*)
15574 xmalloc (sizeof (struct file_name_list
));
15575 dirtmp
->next
= 0; /* New one goes on the end */
15576 dirtmp
->fname
= spec
;
15577 dirtmp
->got_name_map
= 0;
15579 error ("directory name must immediately follow -I");
15581 append_include_chain (dirtmp
, dirtmp
);
15586 /* Open INCLUDEd file. */
15589 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
15592 size_t flen
= strlen (fbeg
);
15593 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
15594 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
15595 struct file_name_list
*searchptr
= 0;
15596 char *fname
; /* Dynamically allocated fname buffer */
15603 dsp
[0].fname
= NULL
;
15605 /* If -I- was specified, don't search current dir, only spec'd ones. */
15606 if (!ignore_srcdir
)
15608 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
15614 if ((nam
= fp
->nominal_fname
) != NULL
)
15616 /* Found a named file. Figure out dir of the file,
15617 and put it in front of the search list. */
15618 dsp
[0].next
= search_start
;
15619 search_start
= dsp
;
15621 ep
= strrchr (nam
, '/');
15622 #ifdef DIR_SEPARATOR
15623 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
15625 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
15626 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
15630 ep
= strrchr (nam
, ']');
15631 if (ep
== NULL
) ep
= strrchr (nam
, '>');
15632 if (ep
== NULL
) ep
= strrchr (nam
, ':');
15633 if (ep
!= NULL
) ep
++;
15638 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
15639 strncpy (dsp
[0].fname
, nam
, n
);
15640 dsp
[0].fname
[n
] = '\0';
15641 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
15642 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
15645 dsp
[0].fname
= NULL
; /* Current directory */
15646 dsp
[0].got_name_map
= 0;
15652 /* Allocate this permanently, because it gets stored in the definitions
15654 fname
= xmalloc (max_include_len
+ flen
+ 4);
15655 /* + 2 above for slash and terminating null. */
15656 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15659 /* If specified file name is absolute, just open it. */
15662 #ifdef DIR_SEPARATOR
15663 || *fbeg
== DIR_SEPARATOR
15667 strncpy (fname
, (char *) fbeg
, flen
);
15669 f
= open_include_file (fname
, NULL
);
15675 /* Search directory path, trying to open the file.
15676 Copy each filename tried into FNAME. */
15678 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
15680 if (searchptr
->fname
)
15682 /* The empty string in a search path is ignored.
15683 This makes it possible to turn off entirely
15684 a standard piece of the list. */
15685 if (searchptr
->fname
[0] == 0)
15687 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
15688 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
15689 strcat (fname
, "/");
15690 fname
[strlen (fname
) + flen
] = 0;
15695 strncat (fname
, fbeg
, flen
);
15697 /* Change this 1/2 Unix 1/2 VMS file specification into a
15698 full VMS file specification */
15699 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
15701 /* Fix up the filename */
15702 hack_vms_include_specification (fname
);
15706 /* This is a normal VMS filespec, so use it unchanged. */
15707 strncpy (fname
, (char *) fbeg
, flen
);
15709 #if 0 /* Not for g77. */
15710 /* if it's '#include filename', add the missing .h */
15711 if (strchr (fname
, '.') == NULL
)
15712 strcat (fname
, ".h");
15716 f
= open_include_file (fname
, searchptr
);
15718 if (f
== NULL
&& errno
== EACCES
)
15720 print_containing_files (FFEBAD_severityWARNING
);
15721 /* xgettext:no-c-format */
15722 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15723 FFEBAD_severityWARNING
);
15724 ffebad_string (fname
);
15725 ffebad_here (0, l
, c
);
15736 /* A file that was not found. */
15738 strncpy (fname
, (char *) fbeg
, flen
);
15740 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
15741 ffebad_start (FFEBAD_OPEN_INCLUDE
);
15742 ffebad_here (0, l
, c
);
15743 ffebad_string (fname
);
15747 if (dsp
[0].fname
!= NULL
)
15748 free (dsp
[0].fname
);
15753 if (indepth
>= (INPUT_STACK_MAX
- 1))
15755 print_containing_files (FFEBAD_severityFATAL
);
15756 /* xgettext:no-c-format */
15757 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15758 FFEBAD_severityFATAL
);
15759 ffebad_string (fname
);
15760 ffebad_here (0, l
, c
);
15765 instack
[indepth
].line
= ffewhere_line_use (l
);
15766 instack
[indepth
].column
= ffewhere_column_use (c
);
15768 fp
= &instack
[indepth
+ 1];
15769 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15770 fp
->nominal_fname
= fp
->fname
= fname
;
15771 fp
->dir
= searchptr
;
15774 input_file_stack_tick
++;
15779 /**INDENT* (Do not reformat this comment even with -fca option.)
15780 Data-gathering files: Given the source file listed below, compiled with
15781 f2c I obtained the output file listed after that, and from the output
15782 file I derived the above code.
15784 -------- (begin input file to f2c)
15790 double precision D1,D2
15792 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15819 c FFEINTRIN_impACOS
15820 call fooR(ACOS(R1))
15821 c FFEINTRIN_impAIMAG
15822 call fooR(AIMAG(C1))
15823 c FFEINTRIN_impAINT
15824 call fooR(AINT(R1))
15825 c FFEINTRIN_impALOG
15826 call fooR(ALOG(R1))
15827 c FFEINTRIN_impALOG10
15828 call fooR(ALOG10(R1))
15829 c FFEINTRIN_impAMAX0
15830 call fooR(AMAX0(I1,I2))
15831 c FFEINTRIN_impAMAX1
15832 call fooR(AMAX1(R1,R2))
15833 c FFEINTRIN_impAMIN0
15834 call fooR(AMIN0(I1,I2))
15835 c FFEINTRIN_impAMIN1
15836 call fooR(AMIN1(R1,R2))
15837 c FFEINTRIN_impAMOD
15838 call fooR(AMOD(R1,R2))
15839 c FFEINTRIN_impANINT
15840 call fooR(ANINT(R1))
15841 c FFEINTRIN_impASIN
15842 call fooR(ASIN(R1))
15843 c FFEINTRIN_impATAN
15844 call fooR(ATAN(R1))
15845 c FFEINTRIN_impATAN2
15846 call fooR(ATAN2(R1,R2))
15847 c FFEINTRIN_impCABS
15848 call fooR(CABS(C1))
15849 c FFEINTRIN_impCCOS
15850 call fooC(CCOS(C1))
15851 c FFEINTRIN_impCEXP
15852 call fooC(CEXP(C1))
15853 c FFEINTRIN_impCHAR
15854 call fooA(CHAR(I1))
15855 c FFEINTRIN_impCLOG
15856 call fooC(CLOG(C1))
15857 c FFEINTRIN_impCONJG
15858 call fooC(CONJG(C1))
15861 c FFEINTRIN_impCOSH
15862 call fooR(COSH(R1))
15863 c FFEINTRIN_impCSIN
15864 call fooC(CSIN(C1))
15865 c FFEINTRIN_impCSQRT
15866 call fooC(CSQRT(C1))
15867 c FFEINTRIN_impDABS
15868 call fooD(DABS(D1))
15869 c FFEINTRIN_impDACOS
15870 call fooD(DACOS(D1))
15871 c FFEINTRIN_impDASIN
15872 call fooD(DASIN(D1))
15873 c FFEINTRIN_impDATAN
15874 call fooD(DATAN(D1))
15875 c FFEINTRIN_impDATAN2
15876 call fooD(DATAN2(D1,D2))
15877 c FFEINTRIN_impDCOS
15878 call fooD(DCOS(D1))
15879 c FFEINTRIN_impDCOSH
15880 call fooD(DCOSH(D1))
15881 c FFEINTRIN_impDDIM
15882 call fooD(DDIM(D1,D2))
15883 c FFEINTRIN_impDEXP
15884 call fooD(DEXP(D1))
15886 call fooR(DIM(R1,R2))
15887 c FFEINTRIN_impDINT
15888 call fooD(DINT(D1))
15889 c FFEINTRIN_impDLOG
15890 call fooD(DLOG(D1))
15891 c FFEINTRIN_impDLOG10
15892 call fooD(DLOG10(D1))
15893 c FFEINTRIN_impDMAX1
15894 call fooD(DMAX1(D1,D2))
15895 c FFEINTRIN_impDMIN1
15896 call fooD(DMIN1(D1,D2))
15897 c FFEINTRIN_impDMOD
15898 call fooD(DMOD(D1,D2))
15899 c FFEINTRIN_impDNINT
15900 call fooD(DNINT(D1))
15901 c FFEINTRIN_impDPROD
15902 call fooD(DPROD(R1,R2))
15903 c FFEINTRIN_impDSIGN
15904 call fooD(DSIGN(D1,D2))
15905 c FFEINTRIN_impDSIN
15906 call fooD(DSIN(D1))
15907 c FFEINTRIN_impDSINH
15908 call fooD(DSINH(D1))
15909 c FFEINTRIN_impDSQRT
15910 call fooD(DSQRT(D1))
15911 c FFEINTRIN_impDTAN
15912 call fooD(DTAN(D1))
15913 c FFEINTRIN_impDTANH
15914 call fooD(DTANH(D1))
15917 c FFEINTRIN_impIABS
15918 call fooI(IABS(I1))
15919 c FFEINTRIN_impICHAR
15920 call fooI(ICHAR(A1))
15921 c FFEINTRIN_impIDIM
15922 call fooI(IDIM(I1,I2))
15923 c FFEINTRIN_impIDNINT
15924 call fooI(IDNINT(D1))
15925 c FFEINTRIN_impINDEX
15926 call fooI(INDEX(A1,A2))
15927 c FFEINTRIN_impISIGN
15928 call fooI(ISIGN(I1,I2))
15932 call fooL(LGE(A1,A2))
15934 call fooL(LGT(A1,A2))
15936 call fooL(LLE(A1,A2))
15938 call fooL(LLT(A1,A2))
15939 c FFEINTRIN_impMAX0
15940 call fooI(MAX0(I1,I2))
15941 c FFEINTRIN_impMAX1
15942 call fooI(MAX1(R1,R2))
15943 c FFEINTRIN_impMIN0
15944 call fooI(MIN0(I1,I2))
15945 c FFEINTRIN_impMIN1
15946 call fooI(MIN1(R1,R2))
15948 call fooI(MOD(I1,I2))
15949 c FFEINTRIN_impNINT
15950 call fooI(NINT(R1))
15951 c FFEINTRIN_impSIGN
15952 call fooR(SIGN(R1,R2))
15955 c FFEINTRIN_impSINH
15956 call fooR(SINH(R1))
15957 c FFEINTRIN_impSQRT
15958 call fooR(SQRT(R1))
15961 c FFEINTRIN_impTANH
15962 call fooR(TANH(R1))
15963 c FFEINTRIN_imp_CMPLX_C
15964 call fooC(cmplx(C1,C2))
15965 c FFEINTRIN_imp_CMPLX_D
15966 call fooZ(cmplx(D1,D2))
15967 c FFEINTRIN_imp_CMPLX_I
15968 call fooC(cmplx(I1,I2))
15969 c FFEINTRIN_imp_CMPLX_R
15970 call fooC(cmplx(R1,R2))
15971 c FFEINTRIN_imp_DBLE_C
15972 call fooD(dble(C1))
15973 c FFEINTRIN_imp_DBLE_D
15974 call fooD(dble(D1))
15975 c FFEINTRIN_imp_DBLE_I
15976 call fooD(dble(I1))
15977 c FFEINTRIN_imp_DBLE_R
15978 call fooD(dble(R1))
15979 c FFEINTRIN_imp_INT_C
15981 c FFEINTRIN_imp_INT_D
15983 c FFEINTRIN_imp_INT_I
15985 c FFEINTRIN_imp_INT_R
15987 c FFEINTRIN_imp_REAL_C
15988 call fooR(real(C1))
15989 c FFEINTRIN_imp_REAL_D
15990 call fooR(real(D1))
15991 c FFEINTRIN_imp_REAL_I
15992 call fooR(real(I1))
15993 c FFEINTRIN_imp_REAL_R
15994 call fooR(real(R1))
15996 c FFEINTRIN_imp_INT_D:
15998 c FFEINTRIN_specIDINT
15999 call fooI(IDINT(D1))
16001 c FFEINTRIN_imp_INT_R:
16003 c FFEINTRIN_specIFIX
16004 call fooI(IFIX(R1))
16005 c FFEINTRIN_specINT
16008 c FFEINTRIN_imp_REAL_D:
16010 c FFEINTRIN_specSNGL
16011 call fooR(SNGL(D1))
16013 c FFEINTRIN_imp_REAL_I:
16015 c FFEINTRIN_specFLOAT
16016 call fooR(FLOAT(I1))
16017 c FFEINTRIN_specREAL
16018 call fooR(REAL(I1))
16021 -------- (end input file to f2c)
16023 -------- (begin output from providing above input file as input to:
16024 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16025 -------- -e "s:^#.*$::g"')
16027 // -- translated by f2c (version 19950223).
16028 You must link the resulting object file with the libraries:
16029 -lf2c -lm (in that order)
16033 // f2c.h -- Standard Fortran to C header file //
16035 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16037 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16042 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16043 // we assume short, float are OK //
16044 typedef long int // long int // integer;
16045 typedef char *address;
16046 typedef short int shortint;
16047 typedef float real;
16048 typedef double doublereal;
16049 typedef struct { real r, i; } complex;
16050 typedef struct { doublereal r, i; } doublecomplex;
16051 typedef long int // long int // logical;
16052 typedef short int shortlogical;
16053 typedef char logical1;
16054 typedef char integer1;
16055 // typedef long long longint; // // system-dependent //
16060 // Extern is for use with -E //
16074 typedef long int // int or long int // flag;
16075 typedef long int // int or long int // ftnlen;
16076 typedef long int // int or long int // ftnint;
16079 //external read, write//
16088 //internal read, write//
16118 //rewind, backspace, endfile//
16130 ftnint *inex; //parameters in standard's order//
16156 union Multitype { // for multiple entry points //
16167 typedef union Multitype Multitype;
16169 typedef long Long; // No longer used; formerly in Namelist //
16171 struct Vardesc { // for Namelist //
16177 typedef struct Vardesc Vardesc;
16184 typedef struct Namelist Namelist;
16193 // procedure parameter types for -A and -C++ //
16198 typedef int // Unknown procedure type // (*U_fp)();
16199 typedef shortint (*J_fp)();
16200 typedef integer (*I_fp)();
16201 typedef real (*R_fp)();
16202 typedef doublereal (*D_fp)(), (*E_fp)();
16203 typedef // Complex // void (*C_fp)();
16204 typedef // Double Complex // void (*Z_fp)();
16205 typedef logical (*L_fp)();
16206 typedef shortlogical (*K_fp)();
16207 typedef // Character // void (*H_fp)();
16208 typedef // Subroutine // int (*S_fp)();
16210 // E_fp is for real functions when -R is not specified //
16211 typedef void C_f; // complex function //
16212 typedef void H_f; // character function //
16213 typedef void Z_f; // double complex function //
16214 typedef doublereal E_f; // real function with -R not specified //
16216 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16219 // (No such symbols should be defined in a strict ANSI C compiler.
16220 We can avoid trouble with f2c-translated code by using
16245 // Main program // MAIN__()
16247 // System generated locals //
16250 doublereal d__1, d__2;
16252 doublecomplex z__1, z__2, z__3;
16256 // Builtin functions //
16259 double pow_ri(), pow_di();
16263 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16264 asin(), atan(), atan2(), c_abs();
16265 void c_cos(), c_exp(), c_log(), r_cnjg();
16266 double cos(), cosh();
16267 void c_sin(), c_sqrt();
16268 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16269 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16270 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16271 logical l_ge(), l_gt(), l_le(), l_lt();
16275 // Local variables //
16276 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16277 fool_(), fooz_(), getem_();
16278 static char a1[10], a2[10];
16279 static complex c1, c2;
16280 static doublereal d1, d2;
16281 static integer i1, i2;
16282 static real r1, r2;
16285 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16293 d__1 = (doublereal) i1;
16294 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16304 c_div(&q__1, &c1, &c2);
16306 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16308 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16311 i__1 = pow_ii(&i1, &i2);
16313 r__1 = pow_ri(&r1, &i1);
16315 d__1 = pow_di(&d1, &i1);
16317 pow_ci(&q__1, &c1, &i1);
16319 d__1 = (doublereal) r1;
16320 d__2 = (doublereal) r2;
16321 r__1 = pow_dd(&d__1, &d__2);
16323 d__2 = (doublereal) r1;
16324 d__1 = pow_dd(&d__2, &d1);
16326 d__1 = pow_dd(&d1, &d2);
16328 d__2 = (doublereal) r1;
16329 d__1 = pow_dd(&d1, &d__2);
16331 z__2.r = c1.r, z__2.i = c1.i;
16332 z__3.r = c2.r, z__3.i = c2.i;
16333 pow_zz(&z__1, &z__2, &z__3);
16334 q__1.r = z__1.r, q__1.i = z__1.i;
16336 z__2.r = c1.r, z__2.i = c1.i;
16337 z__3.r = r1, z__3.i = 0.;
16338 pow_zz(&z__1, &z__2, &z__3);
16339 q__1.r = z__1.r, q__1.i = z__1.i;
16341 z__2.r = c1.r, z__2.i = c1.i;
16342 z__3.r = d1, z__3.i = 0.;
16343 pow_zz(&z__1, &z__2, &z__3);
16345 // FFEINTRIN_impABS //
16346 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16348 // FFEINTRIN_impACOS //
16351 // FFEINTRIN_impAIMAG //
16352 r__1 = r_imag(&c1);
16354 // FFEINTRIN_impAINT //
16357 // FFEINTRIN_impALOG //
16360 // FFEINTRIN_impALOG10 //
16361 r__1 = r_lg10(&r1);
16363 // FFEINTRIN_impAMAX0 //
16364 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16366 // FFEINTRIN_impAMAX1 //
16367 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16369 // FFEINTRIN_impAMIN0 //
16370 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16372 // FFEINTRIN_impAMIN1 //
16373 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16375 // FFEINTRIN_impAMOD //
16376 r__1 = r_mod(&r1, &r2);
16378 // FFEINTRIN_impANINT //
16379 r__1 = r_nint(&r1);
16381 // FFEINTRIN_impASIN //
16384 // FFEINTRIN_impATAN //
16387 // FFEINTRIN_impATAN2 //
16388 r__1 = atan2(r1, r2);
16390 // FFEINTRIN_impCABS //
16393 // FFEINTRIN_impCCOS //
16396 // FFEINTRIN_impCEXP //
16399 // FFEINTRIN_impCHAR //
16400 *(unsigned char *)&ch__1[0] = i1;
16402 // FFEINTRIN_impCLOG //
16405 // FFEINTRIN_impCONJG //
16406 r_cnjg(&q__1, &c1);
16408 // FFEINTRIN_impCOS //
16411 // FFEINTRIN_impCOSH //
16414 // FFEINTRIN_impCSIN //
16417 // FFEINTRIN_impCSQRT //
16418 c_sqrt(&q__1, &c1);
16420 // FFEINTRIN_impDABS //
16421 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16423 // FFEINTRIN_impDACOS //
16426 // FFEINTRIN_impDASIN //
16429 // FFEINTRIN_impDATAN //
16432 // FFEINTRIN_impDATAN2 //
16433 d__1 = atan2(d1, d2);
16435 // FFEINTRIN_impDCOS //
16438 // FFEINTRIN_impDCOSH //
16441 // FFEINTRIN_impDDIM //
16442 d__1 = d_dim(&d1, &d2);
16444 // FFEINTRIN_impDEXP //
16447 // FFEINTRIN_impDIM //
16448 r__1 = r_dim(&r1, &r2);
16450 // FFEINTRIN_impDINT //
16453 // FFEINTRIN_impDLOG //
16456 // FFEINTRIN_impDLOG10 //
16457 d__1 = d_lg10(&d1);
16459 // FFEINTRIN_impDMAX1 //
16460 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16462 // FFEINTRIN_impDMIN1 //
16463 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16465 // FFEINTRIN_impDMOD //
16466 d__1 = d_mod(&d1, &d2);
16468 // FFEINTRIN_impDNINT //
16469 d__1 = d_nint(&d1);
16471 // FFEINTRIN_impDPROD //
16472 d__1 = (doublereal) r1 * r2;
16474 // FFEINTRIN_impDSIGN //
16475 d__1 = d_sign(&d1, &d2);
16477 // FFEINTRIN_impDSIN //
16480 // FFEINTRIN_impDSINH //
16483 // FFEINTRIN_impDSQRT //
16486 // FFEINTRIN_impDTAN //
16489 // FFEINTRIN_impDTANH //
16492 // FFEINTRIN_impEXP //
16495 // FFEINTRIN_impIABS //
16496 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16498 // FFEINTRIN_impICHAR //
16499 i__1 = *(unsigned char *)a1;
16501 // FFEINTRIN_impIDIM //
16502 i__1 = i_dim(&i1, &i2);
16504 // FFEINTRIN_impIDNINT //
16505 i__1 = i_dnnt(&d1);
16507 // FFEINTRIN_impINDEX //
16508 i__1 = i_indx(a1, a2, 10L, 10L);
16510 // FFEINTRIN_impISIGN //
16511 i__1 = i_sign(&i1, &i2);
16513 // FFEINTRIN_impLEN //
16514 i__1 = i_len(a1, 10L);
16516 // FFEINTRIN_impLGE //
16517 L__1 = l_ge(a1, a2, 10L, 10L);
16519 // FFEINTRIN_impLGT //
16520 L__1 = l_gt(a1, a2, 10L, 10L);
16522 // FFEINTRIN_impLLE //
16523 L__1 = l_le(a1, a2, 10L, 10L);
16525 // FFEINTRIN_impLLT //
16526 L__1 = l_lt(a1, a2, 10L, 10L);
16528 // FFEINTRIN_impMAX0 //
16529 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16531 // FFEINTRIN_impMAX1 //
16532 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16534 // FFEINTRIN_impMIN0 //
16535 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16537 // FFEINTRIN_impMIN1 //
16538 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16540 // FFEINTRIN_impMOD //
16543 // FFEINTRIN_impNINT //
16544 i__1 = i_nint(&r1);
16546 // FFEINTRIN_impSIGN //
16547 r__1 = r_sign(&r1, &r2);
16549 // FFEINTRIN_impSIN //
16552 // FFEINTRIN_impSINH //
16555 // FFEINTRIN_impSQRT //
16558 // FFEINTRIN_impTAN //
16561 // FFEINTRIN_impTANH //
16564 // FFEINTRIN_imp_CMPLX_C //
16567 q__1.r = r__1, q__1.i = r__2;
16569 // FFEINTRIN_imp_CMPLX_D //
16570 z__1.r = d1, z__1.i = d2;
16572 // FFEINTRIN_imp_CMPLX_I //
16575 q__1.r = r__1, q__1.i = r__2;
16577 // FFEINTRIN_imp_CMPLX_R //
16578 q__1.r = r1, q__1.i = r2;
16580 // FFEINTRIN_imp_DBLE_C //
16581 d__1 = (doublereal) c1.r;
16583 // FFEINTRIN_imp_DBLE_D //
16586 // FFEINTRIN_imp_DBLE_I //
16587 d__1 = (doublereal) i1;
16589 // FFEINTRIN_imp_DBLE_R //
16590 d__1 = (doublereal) r1;
16592 // FFEINTRIN_imp_INT_C //
16593 i__1 = (integer) c1.r;
16595 // FFEINTRIN_imp_INT_D //
16596 i__1 = (integer) d1;
16598 // FFEINTRIN_imp_INT_I //
16601 // FFEINTRIN_imp_INT_R //
16602 i__1 = (integer) r1;
16604 // FFEINTRIN_imp_REAL_C //
16607 // FFEINTRIN_imp_REAL_D //
16610 // FFEINTRIN_imp_REAL_I //
16613 // FFEINTRIN_imp_REAL_R //
16617 // FFEINTRIN_imp_INT_D: //
16619 // FFEINTRIN_specIDINT //
16620 i__1 = (integer) d1;
16623 // FFEINTRIN_imp_INT_R: //
16625 // FFEINTRIN_specIFIX //
16626 i__1 = (integer) r1;
16628 // FFEINTRIN_specINT //
16629 i__1 = (integer) r1;
16632 // FFEINTRIN_imp_REAL_D: //
16634 // FFEINTRIN_specSNGL //
16638 // FFEINTRIN_imp_REAL_I: //
16640 // FFEINTRIN_specFLOAT //
16643 // FFEINTRIN_specREAL //
16649 -------- (end output file from f2c)