1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
27 Contains compiler-specific functions.
32 /* Understanding this module means understanding the interface between
33 the g77 front end and the gcc back end (or, perhaps, some other
34 back end). In here are the functions called by the front end proper
35 to notify whatever back end is in place about certain things, and
36 also the back-end-specific functions. It's a bear to deal with, so
37 lately I've been trying to simplify things, especially with regard
38 to the gcc-back-end-specific stuff.
40 Building expressions generally seems quite easy, but building decls
41 has been challenging and is undergoing revision. gcc has several
44 TYPE_DECL -- a type (int, float, struct, function, etc.)
45 CONST_DECL -- a constant of some type other than function
46 LABEL_DECL -- a variable or a constant?
47 PARM_DECL -- an argument to a function (a variable that is a dummy)
48 RESULT_DECL -- the return value of a function (a variable)
49 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50 FUNCTION_DECL -- a function (either the actual function or an extern ref)
51 FIELD_DECL -- a field in a struct or union (goes into types)
53 g77 has a set of functions that somewhat parallels the gcc front end
54 when it comes to building decls:
56 Internal Function (one we define, not just declare as extern):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
89 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
92 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
94 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
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 #if FFECOM_targetCURRENT == FFECOM_targetGCC
142 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
145 const char * const language_string
= "GNU F77";
147 /* Stream for reading from the input file. */
150 /* These definitions parallel those in c-decl.c so that code from that
151 module can be used pretty much as is. Much of these defs aren't
152 otherwise used, i.e. by g77 code per se, except some of them are used
153 to build some of them that are. The ones that are global (i.e. not
154 "static") are those that ste.c and such might use (directly
155 or by using com macros that reference them in their definitions). */
157 tree string_type_node
;
159 /* The rest of these are inventions for g77, though there might be
160 similar things in the C front end. As they are found, these
161 inventions should be renamed to be canonical. Note that only
162 the ones currently required to be global are so. */
164 static tree ffecom_tree_fun_type_void
;
166 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
167 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
168 tree ffecom_integer_one_node
; /* " */
169 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
171 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
172 just use build_function_type and build_pointer_type on the
173 appropriate _tree_type array element. */
175 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
176 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
177 static tree ffecom_tree_subr_type
;
178 static tree ffecom_tree_ptr_to_subr_type
;
179 static tree ffecom_tree_blockdata_type
;
181 static tree ffecom_tree_xargc_
;
183 ffecomSymbol ffecom_symbol_null_
192 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
193 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
195 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
196 tree ffecom_f2c_integer_type_node
;
197 tree ffecom_f2c_ptr_to_integer_type_node
;
198 tree ffecom_f2c_address_type_node
;
199 tree ffecom_f2c_real_type_node
;
200 tree ffecom_f2c_ptr_to_real_type_node
;
201 tree ffecom_f2c_doublereal_type_node
;
202 tree ffecom_f2c_complex_type_node
;
203 tree ffecom_f2c_doublecomplex_type_node
;
204 tree ffecom_f2c_longint_type_node
;
205 tree ffecom_f2c_logical_type_node
;
206 tree ffecom_f2c_flag_type_node
;
207 tree ffecom_f2c_ftnlen_type_node
;
208 tree ffecom_f2c_ftnlen_zero_node
;
209 tree ffecom_f2c_ftnlen_one_node
;
210 tree ffecom_f2c_ftnlen_two_node
;
211 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
212 tree ffecom_f2c_ftnint_type_node
;
213 tree ffecom_f2c_ptr_to_ftnint_type_node
;
214 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
216 /* Simple definitions and enumerations. */
218 #ifndef FFECOM_sizeMAXSTACKITEM
219 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
220 larger than this # bytes
221 off stack if possible. */
224 /* For systems that have large enough stacks, they should define
225 this to 0, and here, for ease of use later on, we just undefine
228 #if FFECOM_sizeMAXSTACKITEM == 0
229 #undef FFECOM_sizeMAXSTACKITEM
235 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
236 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
237 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
238 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
239 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
240 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
241 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
242 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
243 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
244 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
245 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
246 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
247 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
248 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
252 /* Internal typedefs. */
254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
255 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
256 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
258 /* Private include files. */
261 /* Internal structure definitions. */
263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
264 struct _ffecom_concat_list_
269 ffetargetCharacterSize minlen
;
270 ffetargetCharacterSize maxlen
;
272 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
274 /* Static functions (internal). */
276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
277 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
278 static tree
ffecom_widest_expr_type_ (ffebld list
);
279 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
280 tree dest_size
, tree source_tree
,
281 ffebld source
, bool scalar_arg
);
282 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
283 tree args
, tree callee_commons
,
285 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
286 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
287 bool is_f2c_complex
, tree type
,
288 tree args
, tree dest_tree
,
289 ffebld dest
, bool *dest_used
,
290 tree callee_commons
, bool scalar_args
, tree hook
);
291 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
292 bool is_f2c_complex
, tree type
,
293 ffebld left
, ffebld right
,
294 tree dest_tree
, ffebld dest
,
295 bool *dest_used
, tree callee_commons
,
296 bool scalar_args
, bool ref
, tree hook
);
297 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
298 ffebld expr
, bool with_null
);
299 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
300 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
301 static ffecomConcatList_
302 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
304 ffetargetCharacterSize max
);
305 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
306 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
307 ffetargetCharacterSize max
);
308 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
309 ffesymbol member
, tree member_type
,
310 ffetargetOffset offset
);
311 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
312 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
313 bool *dest_used
, bool assignp
, bool widenp
);
314 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
315 ffebld dest
, bool *dest_used
);
316 static tree
ffecom_expr_power_integer_ (ffebld expr
);
317 static void ffecom_expr_transform_ (ffebld expr
);
318 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
319 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
321 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
322 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
323 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
324 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
325 static tree
ffecom_get_identifier_ (const char *text
);
326 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
329 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
330 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
331 static tree
ffecom_init_zero_ (tree decl
);
332 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
334 static tree
ffecom_intrinsic_len_ (ffebld expr
);
335 static void ffecom_let_char_ (tree dest_tree
,
337 ffetargetCharacterSize dest_size
,
339 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
340 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
341 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
342 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
344 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
346 static void ffecom_start_progunit_ (void);
347 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
348 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
349 static void ffecom_transform_common_ (ffesymbol s
);
350 static void ffecom_transform_equiv_ (ffestorag st
);
351 static tree
ffecom_transform_namelist_ (ffesymbol s
);
352 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
354 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
355 tree
*size
, tree tree
);
356 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
357 tree dest_tree
, ffebld dest
,
358 bool *dest_used
, tree hook
);
359 static tree
ffecom_type_localvar_ (ffesymbol s
,
362 static tree
ffecom_type_namelist_ (void);
363 static tree
ffecom_type_vardesc_ (void);
364 static tree
ffecom_vardesc_ (ffebld expr
);
365 static tree
ffecom_vardesc_array_ (ffesymbol s
);
366 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
367 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
368 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
369 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
371 /* These are static functions that parallel those found in the C front
372 end and thus have the same names. */
374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
375 static tree
bison_rule_compstmt_ (void);
376 static void bison_rule_pushlevel_ (void);
377 static void delete_block (tree block
);
378 static int duplicate_decls (tree newdecl
, tree olddecl
);
379 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
380 static void finish_function (int nested
);
381 static const char *lang_printable_name (tree decl
, int v
);
382 static tree
lookup_name_current_level (tree name
);
383 static struct binding_level
*make_binding_level (void);
384 static void pop_f_function_context (void);
385 static void push_f_function_context (void);
386 static void push_parm_decl (tree parm
);
387 static tree
pushdecl_top_level (tree decl
);
388 static int kept_level_p (void);
389 static tree
storedecls (tree decls
);
390 static void store_parm_decls (int is_main_program
);
391 static tree
start_decl (tree decl
, bool is_top_level
);
392 static void start_function (tree name
, tree type
, int nested
, int public);
393 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
394 #if FFECOM_GCC_INCLUDE
395 static void ffecom_file_ (const char *name
);
396 static void ffecom_initialize_char_syntax_ (void);
397 static void ffecom_close_include_ (FILE *f
);
398 static int ffecom_decode_include_option_ (char *spec
);
399 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
401 #endif /* FFECOM_GCC_INCLUDE */
403 /* Static objects accessed by functions in this module. */
405 static ffesymbol ffecom_primary_entry_
= NULL
;
406 static ffesymbol ffecom_nested_entry_
= NULL
;
407 static ffeinfoKind ffecom_primary_entry_kind_
;
408 static bool ffecom_primary_entry_is_proc_
;
409 #if FFECOM_targetCURRENT == FFECOM_targetGCC
410 static tree ffecom_outer_function_decl_
;
411 static tree ffecom_previous_function_decl_
;
412 static tree ffecom_which_entrypoint_decl_
;
413 static tree ffecom_float_zero_
= NULL_TREE
;
414 static tree ffecom_float_half_
= NULL_TREE
;
415 static tree ffecom_double_zero_
= NULL_TREE
;
416 static tree ffecom_double_half_
= NULL_TREE
;
417 static tree ffecom_func_result_
;/* For functions. */
418 static tree ffecom_func_length_
;/* For CHARACTER fns. */
419 static ffebld ffecom_list_blockdata_
;
420 static ffebld ffecom_list_common_
;
421 static ffebld ffecom_master_arglist_
;
422 static ffeinfoBasictype ffecom_master_bt_
;
423 static ffeinfoKindtype ffecom_master_kt_
;
424 static ffetargetCharacterSize ffecom_master_size_
;
425 static int ffecom_num_fns_
= 0;
426 static int ffecom_num_entrypoints_
= 0;
427 static bool ffecom_is_altreturning_
= FALSE
;
428 static tree ffecom_multi_type_node_
;
429 static tree ffecom_multi_retval_
;
431 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
432 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
433 static bool ffecom_doing_entry_
= FALSE
;
434 static bool ffecom_transform_only_dummies_
= FALSE
;
435 static int ffecom_typesize_pointer_
;
436 static int ffecom_typesize_integer1_
;
438 /* Holds pointer-to-function expressions. */
440 static tree ffecom_gfrt_
[FFECOM_gfrt
]
443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
444 #include "com-rt.def"
448 /* Holds the external names of the functions. */
450 static const char *ffecom_gfrt_name_
[FFECOM_gfrt
]
453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
454 #include "com-rt.def"
458 /* Whether the function returns. */
460 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
463 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
464 #include "com-rt.def"
468 /* Whether the function returns type complex. */
470 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
474 #include "com-rt.def"
478 /* Whether the function is const
479 (i.e., has no side effects and only depends on its arguments). */
481 static bool ffecom_gfrt_const_
[FFECOM_gfrt
]
484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
485 #include "com-rt.def"
489 /* Type code for the function return value. */
491 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
494 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
495 #include "com-rt.def"
499 /* String of codes for the function's arguments. */
501 static const char *ffecom_gfrt_argstring_
[FFECOM_gfrt
]
504 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
505 #include "com-rt.def"
508 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
510 /* Internal macros. */
512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
514 /* We let tm.h override the types used here, to handle trivial differences
515 such as the choice of unsigned int or long unsigned int for size_t.
516 When machines start needing nontrivial differences in the size type,
517 it would be best to do something here to figure out automatically
518 from other information what type to use. */
521 #define SIZE_TYPE "long unsigned int"
524 #define ffecom_concat_list_count_(catlist) ((catlist).count)
525 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
526 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
527 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
529 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
530 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
532 /* For each binding contour we allocate a binding_level structure
533 * which records the names defined in that contour.
536 * 1) one for each function definition,
537 * where internal declarations of the parameters appear.
539 * The current meaning of a name can be found by searching the levels from
540 * the current one out to the global one.
543 /* Note that the information in the `names' component of the global contour
544 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
548 /* A chain of _DECL nodes for all variables, constants, functions,
549 and typedef types. These are in the reverse of the order supplied.
553 /* For each level (except not the global one),
554 a chain of BLOCK nodes for all the levels
555 that were entered and exited one level down. */
558 /* The BLOCK node for this level, if one has been preallocated.
559 If 0, the BLOCK is allocated (if needed) when the level is popped. */
562 /* The binding level which this one is contained in (inherits from). */
563 struct binding_level
*level_chain
;
565 /* 0: no ffecom_prepare_* functions called at this level yet;
566 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
567 2: ffecom_prepare_end called. */
571 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
573 /* The binding level currently in effect. */
575 static struct binding_level
*current_binding_level
;
577 /* A chain of binding_level structures awaiting reuse. */
579 static struct binding_level
*free_binding_level
;
581 /* The outermost binding level, for names of file scope.
582 This is created when the compiler is started and exists
583 through the entire run. */
585 static struct binding_level
*global_binding_level
;
587 /* Binding level structures are initialized by copying this one. */
589 static struct binding_level clear_binding_level
591 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
593 /* Language-dependent contents of an identifier. */
595 struct lang_identifier
597 struct tree_identifier ignore
;
598 tree global_value
, local_value
, label_value
;
602 /* Macros for access to language-specific slots in an identifier. */
603 /* Each of these slots contains a DECL node or null. */
605 /* This represents the value which the identifier has in the
606 file-scope namespace. */
607 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
608 (((struct lang_identifier *)(NODE))->global_value)
609 /* This represents the value which the identifier has in the current
611 #define IDENTIFIER_LOCAL_VALUE(NODE) \
612 (((struct lang_identifier *)(NODE))->local_value)
613 /* This represents the value which the identifier has as a label in
614 the current label scope. */
615 #define IDENTIFIER_LABEL_VALUE(NODE) \
616 (((struct lang_identifier *)(NODE))->label_value)
617 /* This is nonzero if the identifier was "made up" by g77 code. */
618 #define IDENTIFIER_INVENTED(NODE) \
619 (((struct lang_identifier *)(NODE))->invented)
621 /* In identifiers, C uses the following fields in a special way:
622 TREE_PUBLIC to record that there was a previous local extern decl.
623 TREE_USED to record that such a decl was used.
624 TREE_ADDRESSABLE to record that the address of such a decl was used. */
626 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
627 that have names. Here so we can clear out their names' definitions
628 at the end of the function. */
630 static tree named_labels
;
632 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
634 static tree shadowed_labels
;
636 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
638 /* Return the subscript expression, modified to do range-checking.
640 `array' is the array to be checked against.
641 `element' is the subscript expression to check.
642 `dim' is the dimension number (starting at 0).
643 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
647 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
648 const char *array_name
)
650 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
651 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
656 if (element
== error_mark_node
)
659 if (TREE_TYPE (low
) != TREE_TYPE (element
))
661 if (TYPE_PRECISION (TREE_TYPE (low
))
662 > TYPE_PRECISION (TREE_TYPE (element
)))
663 element
= convert (TREE_TYPE (low
), element
);
666 low
= convert (TREE_TYPE (element
), low
);
668 high
= convert (TREE_TYPE (element
), high
);
672 element
= ffecom_save_tree (element
);
673 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
678 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
680 ffecom_2 (LE_EXPR
, integer_type_node
,
697 var
= xmalloc (strlen (array_name
) + 20);
698 sprintf (var
, "%s[%s-substring]",
700 dim
? "end" : "start");
701 len
= strlen (var
) + 1;
702 arg1
= build_string (len
, var
);
707 len
= strlen (array_name
) + 1;
708 arg1
= build_string (len
, array_name
);
712 var
= xmalloc (strlen (array_name
) + 40);
713 sprintf (var
, "%s[subscript-%d-of-%d]",
715 dim
+ 1, total_dims
);
716 len
= strlen (var
) + 1;
717 arg1
= build_string (len
, var
);
723 = build_type_variant (build_array_type (char_type_node
,
727 build_int_2 (len
, 0))),
729 TREE_CONSTANT (arg1
) = 1;
730 TREE_STATIC (arg1
) = 1;
731 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
734 /* s_rnge adds one to the element to print it, so bias against
735 that -- want to print a faithful *subscript* value. */
736 arg2
= convert (ffecom_f2c_ftnint_type_node
,
737 ffecom_2 (MINUS_EXPR
,
740 convert (TREE_TYPE (element
),
743 proc
= xmalloc ((len
= strlen (input_filename
)
744 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl
))
747 sprintf (&proc
[0], "%s/%s",
749 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
750 arg3
= build_string (len
, proc
);
755 = build_type_variant (build_array_type (char_type_node
,
759 build_int_2 (len
, 0))),
761 TREE_CONSTANT (arg3
) = 1;
762 TREE_STATIC (arg3
) = 1;
763 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
766 arg4
= convert (ffecom_f2c_ftnint_type_node
,
767 build_int_2 (lineno
, 0));
769 arg1
= build_tree_list (NULL_TREE
, arg1
);
770 arg2
= build_tree_list (NULL_TREE
, arg2
);
771 arg3
= build_tree_list (NULL_TREE
, arg3
);
772 arg4
= build_tree_list (NULL_TREE
, arg4
);
773 TREE_CHAIN (arg3
) = arg4
;
774 TREE_CHAIN (arg2
) = arg3
;
775 TREE_CHAIN (arg1
) = arg2
;
779 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
781 TREE_SIDE_EFFECTS (die
) = 1;
783 element
= ffecom_3 (COND_EXPR
,
792 /* Return the computed element of an array reference.
794 `item' is NULL_TREE, or the transformed pointer to the array.
795 `expr' is the original opARRAYREF expression, which is transformed
796 if `item' is NULL_TREE.
797 `want_ptr' is non-zero if a pointer to the element, instead of
798 the element itself, is to be returned. */
801 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
803 ffebld dims
[FFECOM_dimensionsMAX
];
806 int flatten
= ffe_is_flatten_arrays ();
812 const char *array_name
;
816 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
817 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
819 array_name
= "[expr?]";
821 /* Build up ARRAY_REFs in reverse order (since we're column major
822 here in Fortran land). */
824 for (i
= 0, list
= ffebld_right (expr
);
826 ++i
, list
= ffebld_trail (list
))
828 dims
[i
] = ffebld_head (list
);
829 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
830 ffebld_kindtype (dims
[i
]));
832 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
833 && ffetype_size (type
) > ffecom_typesize_integer1_
)
834 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
835 pointers and 32-bit integers. Do the full 64-bit pointer
836 arithmetic, for codes using arrays for nonstandard heap-like
843 need_ptr
= want_ptr
|| flatten
;
848 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
850 item
= ffecom_expr (ffebld_left (expr
));
852 if (item
== error_mark_node
)
855 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
856 && ! mark_addressable (item
))
857 return error_mark_node
;
860 if (item
== error_mark_node
)
867 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
869 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
871 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
872 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
873 if (flag_bounds_check
)
874 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
876 if (element
== error_mark_node
)
879 /* Widen integral arithmetic as desired while preserving
881 tree_type
= TREE_TYPE (element
);
882 tree_type_x
= tree_type
;
884 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
885 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
886 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
888 if (TREE_TYPE (min
) != tree_type_x
)
889 min
= convert (tree_type_x
, min
);
890 if (TREE_TYPE (element
) != tree_type_x
)
891 element
= convert (tree_type_x
, element
);
893 item
= ffecom_2 (PLUS_EXPR
,
894 build_pointer_type (TREE_TYPE (array
)),
896 size_binop (MULT_EXPR
,
897 size_in_bytes (TREE_TYPE (array
)),
899 fold (build (MINUS_EXPR
,
905 item
= ffecom_1 (INDIRECT_REF
,
906 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
916 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
918 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
919 if (flag_bounds_check
)
920 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
922 if (element
== error_mark_node
)
925 /* Widen integral arithmetic as desired while preserving
927 tree_type
= TREE_TYPE (element
);
928 tree_type_x
= tree_type
;
930 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
931 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
932 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
934 element
= convert (tree_type_x
, element
);
936 item
= ffecom_2 (ARRAY_REF
,
937 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
946 /* This is like gcc's stabilize_reference -- in fact, most of the code
947 comes from that -- but it handles the situation where the reference
948 is going to have its subparts picked at, and it shouldn't change
949 (or trigger extra invocations of functions in the subtrees) due to
950 this. save_expr is a bit overzealous, because we don't need the
951 entire thing calculated and saved like a temp. So, for DECLs, no
952 change is needed, because these are stable aggregates, and ARRAY_REF
953 and such might well be stable too, but for things like calculations,
954 we do need to calculate a snapshot of a value before picking at it. */
956 #if FFECOM_targetCURRENT == FFECOM_targetGCC
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
);
1031 /* A rip-off of gcc's convert.c convert_to_complex function,
1032 reworked to handle complex implemented as C structures
1033 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1037 ffecom_convert_to_complex_ (tree type
, tree expr
)
1039 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1042 assert (TREE_CODE (type
) == RECORD_TYPE
);
1044 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1046 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1048 expr
= convert (subtype
, expr
);
1049 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1050 convert (subtype
, integer_zero_node
));
1053 if (form
== RECORD_TYPE
)
1055 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1056 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1060 expr
= save_expr (expr
);
1061 return ffecom_2 (COMPLEX_EXPR
,
1064 ffecom_1 (REALPART_EXPR
,
1065 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1068 ffecom_1 (IMAGPART_EXPR
,
1069 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1074 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1075 error ("pointer value used where a complex was expected");
1077 error ("aggregate value used where a complex was expected");
1079 return ffecom_2 (COMPLEX_EXPR
, type
,
1080 convert (subtype
, integer_zero_node
),
1081 convert (subtype
, integer_zero_node
));
1085 /* Like gcc's convert(), but crashes if widening might happen. */
1087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1089 ffecom_convert_narrow_ (type
, expr
)
1092 register tree e
= expr
;
1093 register enum tree_code code
= TREE_CODE (type
);
1095 if (type
== TREE_TYPE (e
)
1096 || TREE_CODE (e
) == ERROR_MARK
)
1098 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1099 return fold (build1 (NOP_EXPR
, type
, e
));
1100 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1101 || code
== ERROR_MARK
)
1102 return error_mark_node
;
1103 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1105 assert ("void value not ignored as it ought to be" == NULL
);
1106 return error_mark_node
;
1108 assert (code
!= VOID_TYPE
);
1109 if ((code
!= RECORD_TYPE
)
1110 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1111 assert ("converting COMPLEX to REAL" == NULL
);
1112 assert (code
!= ENUMERAL_TYPE
);
1113 if (code
== INTEGER_TYPE
)
1115 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1116 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1117 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1118 && (TYPE_PRECISION (type
)
1119 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1120 return fold (convert_to_integer (type
, e
));
1122 if (code
== POINTER_TYPE
)
1124 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1125 return fold (convert_to_pointer (type
, e
));
1127 if (code
== REAL_TYPE
)
1129 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1130 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1131 return fold (convert_to_real (type
, e
));
1133 if (code
== COMPLEX_TYPE
)
1135 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1136 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1137 return fold (convert_to_complex (type
, e
));
1139 if (code
== RECORD_TYPE
)
1141 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1142 /* Check that at least the first field name agrees. */
1143 assert (DECL_NAME (TYPE_FIELDS (type
))
1144 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1145 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1146 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1147 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1148 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1150 return fold (ffecom_convert_to_complex_ (type
, e
));
1153 assert ("conversion to non-scalar type requested" == NULL
);
1154 return error_mark_node
;
1158 /* Like gcc's convert(), but crashes if narrowing might happen. */
1160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1162 ffecom_convert_widen_ (type
, expr
)
1165 register tree e
= expr
;
1166 register enum tree_code code
= TREE_CODE (type
);
1168 if (type
== TREE_TYPE (e
)
1169 || TREE_CODE (e
) == ERROR_MARK
)
1171 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1172 return fold (build1 (NOP_EXPR
, type
, e
));
1173 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1174 || code
== ERROR_MARK
)
1175 return error_mark_node
;
1176 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1178 assert ("void value not ignored as it ought to be" == NULL
);
1179 return error_mark_node
;
1181 assert (code
!= VOID_TYPE
);
1182 if ((code
!= RECORD_TYPE
)
1183 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1184 assert ("narrowing COMPLEX to REAL" == NULL
);
1185 assert (code
!= ENUMERAL_TYPE
);
1186 if (code
== INTEGER_TYPE
)
1188 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1189 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1190 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1191 && (TYPE_PRECISION (type
)
1192 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1193 return fold (convert_to_integer (type
, e
));
1195 if (code
== POINTER_TYPE
)
1197 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1198 return fold (convert_to_pointer (type
, e
));
1200 if (code
== REAL_TYPE
)
1202 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1203 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1204 return fold (convert_to_real (type
, e
));
1206 if (code
== COMPLEX_TYPE
)
1208 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1209 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1210 return fold (convert_to_complex (type
, e
));
1212 if (code
== RECORD_TYPE
)
1214 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1215 /* Check that at least the first field name agrees. */
1216 assert (DECL_NAME (TYPE_FIELDS (type
))
1217 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1218 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1219 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1220 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1221 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1223 return fold (ffecom_convert_to_complex_ (type
, e
));
1226 assert ("conversion to non-scalar type requested" == NULL
);
1227 return error_mark_node
;
1231 /* Handles making a COMPLEX type, either the standard
1232 (but buggy?) gbe way, or the safer (but less elegant?)
1235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1237 ffecom_make_complex_type_ (tree subtype
)
1243 if (ffe_is_emulate_complex ())
1245 type
= make_node (RECORD_TYPE
);
1246 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1247 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1248 TYPE_FIELDS (type
) = realfield
;
1253 type
= make_node (COMPLEX_TYPE
);
1254 TREE_TYPE (type
) = subtype
;
1262 /* Chooses either the gbe or the f2c way to build a
1263 complex constant. */
1265 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1267 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1271 if (ffe_is_emulate_complex ())
1273 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1274 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1275 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1279 bothparts
= build_complex (type
, realpart
, imagpart
);
1286 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1288 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1291 tree
*plist
= &list
;
1292 tree trail
= NULL_TREE
; /* Append char length args here. */
1293 tree
*ptrail
= &trail
;
1298 tree wanted
= NULL_TREE
;
1299 static char zed
[] = "0";
1304 while (expr
!= NULL
)
1327 wanted
= ffecom_f2c_complex_type_node
;
1331 wanted
= ffecom_f2c_doublereal_type_node
;
1335 wanted
= ffecom_f2c_doublecomplex_type_node
;
1339 wanted
= ffecom_f2c_real_type_node
;
1343 wanted
= ffecom_f2c_integer_type_node
;
1347 wanted
= ffecom_f2c_longint_type_node
;
1351 assert ("bad argstring code" == NULL
);
1357 exprh
= ffebld_head (expr
);
1361 if ((wanted
== NULL_TREE
)
1364 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1365 [ffeinfo_kindtype (ffebld_info (exprh
))])
1366 == TYPE_MODE (wanted
))))
1368 = build_tree_list (NULL_TREE
,
1369 ffecom_arg_ptr_to_expr (exprh
,
1373 item
= ffecom_arg_expr (exprh
, &length
);
1374 item
= ffecom_convert_widen_ (wanted
, item
);
1377 item
= ffecom_1 (ADDR_EXPR
,
1378 build_pointer_type (TREE_TYPE (item
)),
1382 = build_tree_list (NULL_TREE
,
1386 plist
= &TREE_CHAIN (*plist
);
1387 expr
= ffebld_trail (expr
);
1388 if (length
!= NULL_TREE
)
1390 *ptrail
= build_tree_list (NULL_TREE
, length
);
1391 ptrail
= &TREE_CHAIN (*ptrail
);
1395 /* We've run out of args in the call; if the implementation expects
1396 more, supply null pointers for them, which the implementation can
1397 check to see if an arg was omitted. */
1399 while (*c
!= '\0' && *c
!= '0')
1404 assert ("missing arg to run-time routine!" == NULL
);
1419 assert ("bad arg string code" == NULL
);
1423 = build_tree_list (NULL_TREE
,
1425 plist
= &TREE_CHAIN (*plist
);
1434 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1436 ffecom_widest_expr_type_ (ffebld list
)
1439 ffebld widest
= NULL
;
1441 ffetype widest_type
= NULL
;
1444 for (; list
!= NULL
; list
= ffebld_trail (list
))
1446 item
= ffebld_head (list
);
1449 if ((widest
!= NULL
)
1450 && (ffeinfo_basictype (ffebld_info (item
))
1451 != ffeinfo_basictype (ffebld_info (widest
))))
1453 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1454 ffeinfo_kindtype (ffebld_info (item
)));
1455 if ((widest
== FFEINFO_kindtypeNONE
)
1456 || (ffetype_size (type
)
1457 > ffetype_size (widest_type
)))
1464 assert (widest
!= NULL
);
1465 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1466 [ffeinfo_kindtype (ffebld_info (widest
))];
1467 assert (t
!= NULL_TREE
);
1472 /* Check whether a partial overlap between two expressions is possible.
1474 Can *starting* to write a portion of expr1 change the value
1475 computed (perhaps already, *partially*) by expr2?
1477 Currently, this is a concern only for a COMPLEX expr1. But if it
1478 isn't in COMMON or local EQUIVALENCE, since we don't support
1479 aliasing of arguments, it isn't a concern. */
1482 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1487 switch (ffebld_op (expr1
))
1489 case FFEBLD_opSYMTER
:
1490 sym
= ffebld_symter (expr1
);
1493 case FFEBLD_opARRAYREF
:
1494 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1496 sym
= ffebld_symter (ffebld_left (expr1
));
1503 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1504 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1505 || ! (st
= ffesymbol_storage (sym
))
1506 || ! ffestorag_parent (st
)))
1509 /* It's in COMMON or local EQUIVALENCE. */
1514 /* Check whether dest and source might overlap. ffebld versions of these
1515 might or might not be passed, will be NULL if not.
1517 The test is really whether source_tree is modifiable and, if modified,
1518 might overlap destination such that the value(s) in the destination might
1519 change before it is finally modified. dest_* are the canonized
1520 destination itself. */
1522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1524 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1525 tree source_tree
, ffebld source UNUSED
,
1533 if (source_tree
== NULL_TREE
)
1536 switch (TREE_CODE (source_tree
))
1539 case IDENTIFIER_NODE
:
1550 case TRUNC_DIV_EXPR
:
1552 case FLOOR_DIV_EXPR
:
1553 case ROUND_DIV_EXPR
:
1554 case TRUNC_MOD_EXPR
:
1556 case FLOOR_MOD_EXPR
:
1557 case ROUND_MOD_EXPR
:
1559 case EXACT_DIV_EXPR
:
1560 case FIX_TRUNC_EXPR
:
1562 case FIX_FLOOR_EXPR
:
1563 case FIX_ROUND_EXPR
:
1578 case BIT_ANDTC_EXPR
:
1580 case TRUTH_ANDIF_EXPR
:
1581 case TRUTH_ORIF_EXPR
:
1582 case TRUTH_AND_EXPR
:
1584 case TRUTH_XOR_EXPR
:
1585 case TRUTH_NOT_EXPR
:
1601 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1602 TREE_OPERAND (source_tree
, 1), NULL
,
1606 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1607 TREE_OPERAND (source_tree
, 0), NULL
,
1612 case NON_LVALUE_EXPR
:
1614 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1617 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1619 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1624 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1625 TREE_OPERAND (source_tree
, 1), NULL
,
1627 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1628 TREE_OPERAND (source_tree
, 2), NULL
,
1633 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1635 TREE_OPERAND (source_tree
, 0));
1639 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1642 source_decl
= source_tree
;
1643 source_offset
= bitsize_zero_node
;
1644 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1648 case REFERENCE_EXPR
:
1649 case PREDECREMENT_EXPR
:
1650 case PREINCREMENT_EXPR
:
1651 case POSTDECREMENT_EXPR
:
1652 case POSTINCREMENT_EXPR
:
1660 /* Come here when source_decl, source_offset, and source_size filled
1661 in appropriately. */
1663 if (source_decl
== NULL_TREE
)
1664 return FALSE
; /* No decl involved, so no overlap. */
1666 if (source_decl
!= dest_decl
)
1667 return FALSE
; /* Different decl, no overlap. */
1669 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1670 return TRUE
; /* Assignment into entire assumed-size
1671 array? Shouldn't happen.... */
1673 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1674 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1676 convert (TREE_TYPE (dest_offset
),
1678 convert (TREE_TYPE (dest_offset
),
1681 if (integer_onep (t
))
1682 return FALSE
; /* Destination precedes source. */
1685 || (source_size
== NULL_TREE
)
1686 || (TREE_CODE (source_size
) == ERROR_MARK
)
1687 || integer_zerop (source_size
))
1688 return TRUE
; /* No way to tell if dest follows source. */
1690 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1691 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1693 convert (TREE_TYPE (source_offset
),
1695 convert (TREE_TYPE (source_offset
),
1698 if (integer_onep (t
))
1699 return FALSE
; /* Destination follows source. */
1701 return TRUE
; /* Destination and source overlap. */
1705 /* Check whether dest might overlap any of a list of arguments or is
1706 in a COMMON area the callee might know about (and thus modify). */
1708 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1710 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1711 tree args
, tree callee_commons
,
1719 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1722 if (dest_decl
== NULL_TREE
)
1723 return FALSE
; /* Seems unlikely! */
1725 /* If the decl cannot be determined reliably, or if its in COMMON
1726 and the callee isn't known to not futz with COMMON via other
1727 means, overlap might happen. */
1729 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1730 || ((callee_commons
!= NULL_TREE
)
1731 && TREE_PUBLIC (dest_decl
)))
1734 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1736 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1737 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1738 arg
, NULL
, scalar_args
))
1746 /* Build a string for a variable name as used by NAMELIST. This means that
1747 if we're using the f2c library, we build an uppercase string, since
1750 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1752 ffecom_build_f2c_string_ (int i
, const char *s
)
1754 if (!ffe_is_f2c_library ())
1755 return build_string (i
, s
);
1764 if (((size_t) i
) > ARRAY_SIZE (space
))
1765 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1769 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1773 t
= build_string (i
, tmp
);
1775 if (((size_t) i
) > ARRAY_SIZE (space
))
1776 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1783 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1784 type to just get whatever the function returns), handling the
1785 f2c value-returning convention, if required, by prepending
1786 to the arglist a pointer to a temporary to receive the return value. */
1788 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1790 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1791 tree type
, tree args
, tree dest_tree
,
1792 ffebld dest
, bool *dest_used
, tree callee_commons
,
1793 bool scalar_args
, tree hook
)
1798 if (dest_used
!= NULL
)
1803 if ((dest_used
== NULL
)
1805 || (ffeinfo_basictype (ffebld_info (dest
))
1806 != FFEINFO_basictypeCOMPLEX
)
1807 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1808 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1809 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1814 tempvar
= ffecom_make_tempvar (ffecom_tree_type
1815 [FFEINFO_basictypeCOMPLEX
][kt
],
1816 FFETARGET_charactersizeNONE
,
1826 tempvar
= dest_tree
;
1831 = build_tree_list (NULL_TREE
,
1832 ffecom_1 (ADDR_EXPR
,
1833 build_pointer_type (TREE_TYPE (tempvar
)),
1835 TREE_CHAIN (item
) = args
;
1837 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1840 if (tempvar
!= dest_tree
)
1841 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1844 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1847 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1848 item
= ffecom_convert_narrow_ (type
, item
);
1854 /* Given two arguments, transform them and make a call to the given
1855 function via ffecom_call_. */
1857 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1859 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1860 tree type
, ffebld left
, ffebld right
,
1861 tree dest_tree
, ffebld dest
, bool *dest_used
,
1862 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1871 /* Pass arguments by reference. */
1872 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1873 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1877 /* Pass arguments by value. */
1878 left_tree
= ffecom_arg_expr (left
, &left_length
);
1879 right_tree
= ffecom_arg_expr (right
, &right_length
);
1883 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1884 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1885 TREE_CHAIN (left_tree
) = right_tree
;
1887 if (left_length
!= NULL_TREE
)
1889 left_length
= build_tree_list (NULL_TREE
, left_length
);
1890 TREE_CHAIN (right_tree
) = left_length
;
1893 if (right_length
!= NULL_TREE
)
1895 right_length
= build_tree_list (NULL_TREE
, right_length
);
1896 if (left_length
!= NULL_TREE
)
1897 TREE_CHAIN (left_length
) = right_length
;
1899 TREE_CHAIN (right_tree
) = right_length
;
1902 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1903 dest_tree
, dest
, dest_used
, callee_commons
,
1908 /* Return ptr/length args for char subexpression
1910 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1911 subexpressions by constructing the appropriate trees for the ptr-to-
1912 character-text and length-of-character-text arguments in a calling
1915 Note that if with_null is TRUE, and the expression is an opCONTER,
1916 a null byte is appended to the string. */
1918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1920 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1924 ffetargetCharacter1 val
;
1925 ffetargetCharacterSize newlen
;
1927 switch (ffebld_op (expr
))
1929 case FFEBLD_opCONTER
:
1930 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1931 newlen
= ffetarget_length_character1 (val
);
1934 /* Begin FFETARGET-NULL-KLUDGE. */
1938 *length
= build_int_2 (newlen
, 0);
1939 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1940 high
= build_int_2 (newlen
, 0);
1941 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1942 item
= build_string (newlen
,
1943 ffetarget_text_character1 (val
));
1944 /* End FFETARGET-NULL-KLUDGE. */
1946 = build_type_variant
1950 (ffecom_f2c_ftnlen_type_node
,
1951 ffecom_f2c_ftnlen_one_node
,
1954 TREE_CONSTANT (item
) = 1;
1955 TREE_STATIC (item
) = 1;
1956 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1960 case FFEBLD_opSYMTER
:
1962 ffesymbol s
= ffebld_symter (expr
);
1964 item
= ffesymbol_hook (s
).decl_tree
;
1965 if (item
== NULL_TREE
)
1967 s
= ffecom_sym_transform_ (s
);
1968 item
= ffesymbol_hook (s
).decl_tree
;
1970 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1972 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1973 *length
= ffesymbol_hook (s
).length_tree
;
1976 *length
= build_int_2 (ffesymbol_size (s
), 0);
1977 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1980 else if (item
== error_mark_node
)
1981 *length
= error_mark_node
;
1983 /* FFEINFO_kindFUNCTION. */
1984 *length
= NULL_TREE
;
1985 if (!ffesymbol_hook (s
).addr
1986 && (item
!= error_mark_node
))
1987 item
= ffecom_1 (ADDR_EXPR
,
1988 build_pointer_type (TREE_TYPE (item
)),
1993 case FFEBLD_opARRAYREF
:
1995 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1997 if (item
== error_mark_node
|| *length
== error_mark_node
)
1999 item
= *length
= error_mark_node
;
2003 item
= ffecom_arrayref_ (item
, expr
, 1);
2007 case FFEBLD_opSUBSTR
:
2011 ffebld thing
= ffebld_right (expr
);
2014 const char *char_name
;
2018 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
2019 start
= ffebld_head (thing
);
2020 thing
= ffebld_trail (thing
);
2021 assert (ffebld_trail (thing
) == NULL
);
2022 end
= ffebld_head (thing
);
2024 /* Determine name for pretty-printing range-check errors. */
2025 for (left_symter
= ffebld_left (expr
);
2026 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2027 left_symter
= ffebld_left (left_symter
))
2029 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2030 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2032 char_name
= "[expr?]";
2034 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2036 if (item
== error_mark_node
|| *length
== error_mark_node
)
2038 item
= *length
= error_mark_node
;
2042 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2044 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2052 end_tree
= ffecom_expr (end
);
2053 if (flag_bounds_check
)
2054 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2056 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2059 if (end_tree
== error_mark_node
)
2061 item
= *length
= error_mark_node
;
2070 start_tree
= ffecom_expr (start
);
2071 if (flag_bounds_check
)
2072 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2074 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2077 if (start_tree
== error_mark_node
)
2079 item
= *length
= error_mark_node
;
2083 start_tree
= ffecom_save_tree (start_tree
);
2085 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2087 ffecom_2 (MINUS_EXPR
,
2088 TREE_TYPE (start_tree
),
2090 ffecom_f2c_ftnlen_one_node
));
2094 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2095 ffecom_f2c_ftnlen_one_node
,
2096 ffecom_2 (MINUS_EXPR
,
2097 ffecom_f2c_ftnlen_type_node
,
2103 end_tree
= ffecom_expr (end
);
2104 if (flag_bounds_check
)
2105 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2107 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2110 if (end_tree
== error_mark_node
)
2112 item
= *length
= error_mark_node
;
2116 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2117 ffecom_f2c_ftnlen_one_node
,
2118 ffecom_2 (MINUS_EXPR
,
2119 ffecom_f2c_ftnlen_type_node
,
2120 end_tree
, start_tree
));
2126 case FFEBLD_opFUNCREF
:
2128 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2131 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2134 if (size
== FFETARGET_charactersizeNONE
)
2135 /* ~~Kludge alert! This should someday be fixed. */
2138 *length
= build_int_2 (size
, 0);
2139 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2141 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2142 == FFEINFO_whereINTRINSIC
)
2146 /* Invocation of an intrinsic returning CHARACTER*1. */
2147 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2151 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2152 assert (ix
!= FFECOM_gfrt
);
2153 item
= ffecom_gfrt_tree_ (ix
);
2158 item
= ffesymbol_hook (s
).decl_tree
;
2159 if (item
== NULL_TREE
)
2161 s
= ffecom_sym_transform_ (s
);
2162 item
= ffesymbol_hook (s
).decl_tree
;
2164 if (item
== error_mark_node
)
2166 item
= *length
= error_mark_node
;
2170 if (!ffesymbol_hook (s
).addr
)
2171 item
= ffecom_1_fn (item
);
2175 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
2177 tempvar
= ffebld_nonter_hook (expr
);
2180 tempvar
= ffecom_1 (ADDR_EXPR
,
2181 build_pointer_type (TREE_TYPE (tempvar
)),
2184 args
= build_tree_list (NULL_TREE
, tempvar
);
2186 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2187 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2190 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2191 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2193 TREE_CHAIN (TREE_CHAIN (args
))
2194 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2195 ffebld_right (expr
));
2199 TREE_CHAIN (TREE_CHAIN (args
))
2200 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2204 item
= ffecom_3s (CALL_EXPR
,
2205 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2206 item
, args
, NULL_TREE
);
2207 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2212 case FFEBLD_opCONVERT
:
2214 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2216 if (item
== error_mark_node
|| *length
== error_mark_node
)
2218 item
= *length
= error_mark_node
;
2222 if ((ffebld_size_known (ffebld_left (expr
))
2223 == FFETARGET_charactersizeNONE
)
2224 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2225 { /* Possible blank-padding needed, copy into
2232 tempvar
= ffecom_make_tempvar (char_type_node
,
2233 ffebld_size (expr
), -1);
2235 tempvar
= ffebld_nonter_hook (expr
);
2238 tempvar
= ffecom_1 (ADDR_EXPR
,
2239 build_pointer_type (TREE_TYPE (tempvar
)),
2242 newlen
= build_int_2 (ffebld_size (expr
), 0);
2243 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2245 args
= build_tree_list (NULL_TREE
, tempvar
);
2246 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2247 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2248 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2249 = build_tree_list (NULL_TREE
, *length
);
2251 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2252 TREE_SIDE_EFFECTS (item
) = 1;
2253 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2258 { /* Just truncate the length. */
2259 *length
= build_int_2 (ffebld_size (expr
), 0);
2260 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2265 assert ("bad op for single char arg expr" == NULL
);
2274 /* Check the size of the type to be sure it doesn't overflow the
2275 "portable" capacities of the compiler back end. `dummy' types
2276 can generally overflow the normal sizes as long as the computations
2277 themselves don't overflow. A particular target of the back end
2278 must still enforce its size requirements, though, and the back
2279 end takes care of this in stor-layout.c. */
2281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2283 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2285 if (TREE_CODE (type
) == ERROR_MARK
)
2288 if (TYPE_SIZE (type
) == NULL_TREE
)
2291 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2294 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2295 || (!dummy
&& (((TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2296 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2298 ffebad_start (FFEBAD_ARRAY_LARGE
);
2299 ffebad_string (ffesymbol_text (s
));
2300 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2303 return error_mark_node
;
2310 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2311 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2312 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2316 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2318 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2323 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2324 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2327 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2328 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2329 ffesymbol_text (s
));
2331 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2332 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2334 DECL_ARTIFICIAL (tlen
) = 1;
2338 if (sz
== FFETARGET_charactersizeNONE
)
2340 assert (tlen
!= NULL_TREE
);
2341 highval
= variable_size (tlen
);
2345 highval
= build_int_2 (sz
, 0);
2346 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2349 type
= build_array_type (type
,
2350 build_range_type (ffecom_f2c_ftnlen_type_node
,
2351 ffecom_f2c_ftnlen_one_node
,
2359 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2361 ffecomConcatList_ catlist;
2362 ffebld expr; // expr of CHARACTER basictype.
2363 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2364 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2366 Scans expr for character subexpressions, updates and returns catlist
2369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2370 static ffecomConcatList_
2371 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2372 ffetargetCharacterSize max
)
2374 ffetargetCharacterSize sz
;
2376 recurse
: /* :::::::::::::::::::: */
2381 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2382 return catlist
; /* Don't append any more items. */
2384 switch (ffebld_op (expr
))
2386 case FFEBLD_opCONTER
:
2387 case FFEBLD_opSYMTER
:
2388 case FFEBLD_opARRAYREF
:
2389 case FFEBLD_opFUNCREF
:
2390 case FFEBLD_opSUBSTR
:
2391 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2392 if they don't need to preserve it. */
2393 if (catlist
.count
== catlist
.max
)
2394 { /* Make a (larger) list. */
2398 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2399 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2400 newmax
* sizeof (newx
[0]));
2401 if (catlist
.max
!= 0)
2403 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2404 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2405 catlist
.max
* sizeof (newx
[0]));
2407 catlist
.max
= newmax
;
2408 catlist
.exprs
= newx
;
2410 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2411 catlist
.minlen
+= sz
;
2413 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2414 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2415 catlist
.maxlen
= sz
;
2417 catlist
.maxlen
+= sz
;
2418 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2419 { /* This item overlaps (or is beyond) the end
2420 of the destination. */
2421 switch (ffebld_op (expr
))
2423 case FFEBLD_opCONTER
:
2424 case FFEBLD_opSYMTER
:
2425 case FFEBLD_opARRAYREF
:
2426 case FFEBLD_opFUNCREF
:
2427 case FFEBLD_opSUBSTR
:
2428 /* ~~Do useful truncations here. */
2432 assert ("op changed or inconsistent switches!" == NULL
);
2436 catlist
.exprs
[catlist
.count
++] = expr
;
2439 case FFEBLD_opPAREN
:
2440 expr
= ffebld_left (expr
);
2441 goto recurse
; /* :::::::::::::::::::: */
2443 case FFEBLD_opCONCATENATE
:
2444 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2445 expr
= ffebld_right (expr
);
2446 goto recurse
; /* :::::::::::::::::::: */
2448 #if 0 /* Breaks passing small actual arg to larger
2449 dummy arg of sfunc */
2450 case FFEBLD_opCONVERT
:
2451 expr
= ffebld_left (expr
);
2453 ffetargetCharacterSize cmax
;
2455 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2457 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2460 goto recurse
; /* :::::::::::::::::::: */
2467 assert ("bad op in _gather_" == NULL
);
2473 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2475 ffecomConcatList_ catlist;
2476 ffecom_concat_list_kill_(catlist);
2478 Anything allocated within the list info is deallocated. */
2480 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2482 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2484 if (catlist
.max
!= 0)
2485 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2486 catlist
.max
* sizeof (catlist
.exprs
[0]));
2490 /* Make list of concatenated string exprs.
2492 Returns a flattened list of concatenated subexpressions given a
2493 tree of such expressions. */
2495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2496 static ffecomConcatList_
2497 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2499 ffecomConcatList_ catlist
;
2501 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2502 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2507 /* Provide some kind of useful info on member of aggregate area,
2508 since current g77/gcc technology does not provide debug info
2509 on these members. */
2511 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2513 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2514 tree member_type UNUSED
, ffetargetOffset offset
)
2524 for (type_id
= member_type
;
2525 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2528 switch (TREE_CODE (type_id
))
2532 type_id
= TYPE_NAME (type_id
);
2537 type_id
= TREE_TYPE (type_id
);
2541 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2542 type_id
= error_mark_node
;
2548 if (ffecom_transform_only_dummies_
2549 || !ffe_is_debug_kludge ())
2550 return; /* Can't do this yet, maybe later. */
2553 + strlen (aggr_type
)
2554 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2556 + IDENTIFIER_LENGTH (type_id
);
2559 if (((size_t) len
) >= ARRAY_SIZE (space
))
2560 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2564 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2566 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2569 value
= build_string (len
, buff
);
2571 = build_type_variant (build_array_type (char_type_node
,
2575 build_int_2 (strlen (buff
), 0))),
2577 decl
= build_decl (VAR_DECL
,
2578 ffecom_get_identifier_ (ffesymbol_text (member
)),
2580 TREE_CONSTANT (decl
) = 1;
2581 TREE_STATIC (decl
) = 1;
2582 DECL_INITIAL (decl
) = error_mark_node
;
2583 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2584 decl
= start_decl (decl
, FALSE
);
2585 finish_decl (decl
, value
, FALSE
);
2587 if (buff
!= &space
[0])
2588 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2592 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2594 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2595 int i; // entry# for this entrypoint (used by master fn)
2596 ffecom_do_entrypoint_(s,i);
2598 Makes a public entry point that calls our private master fn (already
2601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2603 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2606 tree type
; /* Type of function. */
2607 tree multi_retval
; /* Var holding return value (union). */
2608 tree result
; /* Var holding result. */
2609 ffeinfoBasictype bt
;
2613 bool charfunc
; /* All entry points return same type
2615 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2616 bool multi
; /* Master fn has multiple return types. */
2617 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2618 int old_lineno
= lineno
;
2619 const char *old_input_filename
= input_filename
;
2621 input_filename
= ffesymbol_where_filename (fn
);
2622 lineno
= ffesymbol_where_filelinenum (fn
);
2624 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2626 switch (ffecom_primary_entry_kind_
)
2628 case FFEINFO_kindFUNCTION
:
2630 /* Determine actual return type for function. */
2632 gt
= FFEGLOBAL_typeFUNC
;
2633 bt
= ffesymbol_basictype (fn
);
2634 kt
= ffesymbol_kindtype (fn
);
2635 if (bt
== FFEINFO_basictypeNONE
)
2637 ffeimplic_establish_symbol (fn
);
2638 if (ffesymbol_funcresult (fn
) != NULL
)
2639 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2640 bt
= ffesymbol_basictype (fn
);
2641 kt
= ffesymbol_kindtype (fn
);
2644 if (bt
== FFEINFO_basictypeCHARACTER
)
2645 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2646 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2647 && ffesymbol_is_f2c (fn
))
2648 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2650 charfunc
= cmplxfunc
= FALSE
;
2653 type
= ffecom_tree_fun_type_void
;
2654 else if (ffesymbol_is_f2c (fn
))
2655 type
= ffecom_tree_fun_type
[bt
][kt
];
2657 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2659 if ((type
== NULL_TREE
)
2660 || (TREE_TYPE (type
) == NULL_TREE
))
2661 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2663 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2666 case FFEINFO_kindSUBROUTINE
:
2667 gt
= FFEGLOBAL_typeSUBR
;
2668 bt
= FFEINFO_basictypeNONE
;
2669 kt
= FFEINFO_kindtypeNONE
;
2670 if (ffecom_is_altreturning_
)
2671 { /* Am _I_ altreturning? */
2672 for (item
= ffesymbol_dummyargs (fn
);
2674 item
= ffebld_trail (item
))
2676 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2678 altreturning
= TRUE
;
2683 type
= ffecom_tree_subr_type
;
2685 type
= ffecom_tree_fun_type_void
;
2688 type
= ffecom_tree_fun_type_void
;
2695 assert ("say what??" == NULL
);
2697 case FFEINFO_kindANY
:
2698 gt
= FFEGLOBAL_typeANY
;
2699 bt
= FFEINFO_basictypeNONE
;
2700 kt
= FFEINFO_kindtypeNONE
;
2701 type
= error_mark_node
;
2708 /* build_decl uses the current lineno and input_filename to set the decl
2709 source info. So, I've putzed with ffestd and ffeste code to update that
2710 source info to point to the appropriate statement just before calling
2711 ffecom_do_entrypoint (which calls this fn). */
2713 start_function (ffecom_get_external_identifier_ (fn
),
2715 0, /* nested/inline */
2716 1); /* TREE_PUBLIC */
2718 if (((g
= ffesymbol_global (fn
)) != NULL
)
2719 && ((ffeglobal_type (g
) == gt
)
2720 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2722 ffeglobal_set_hook (g
, current_function_decl
);
2725 /* Reset args in master arg list so they get retransitioned. */
2727 for (item
= ffecom_master_arglist_
;
2729 item
= ffebld_trail (item
))
2734 arg
= ffebld_head (item
);
2735 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2736 continue; /* Alternate return or some such thing. */
2737 s
= ffebld_symter (arg
);
2738 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2739 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2742 /* Build dummy arg list for this entry point. */
2744 if (charfunc
|| cmplxfunc
)
2745 { /* Prepend arg for where result goes. */
2750 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2752 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2754 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2756 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2759 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2761 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2763 type
= build_pointer_type (type
);
2764 result
= build_decl (PARM_DECL
, result
, type
);
2766 push_parm_decl (result
);
2767 ffecom_func_result_
= result
;
2771 push_parm_decl (length
);
2772 ffecom_func_length_
= length
;
2776 result
= DECL_RESULT (current_function_decl
);
2778 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2780 store_parm_decls (0);
2782 ffecom_start_compstmt ();
2783 /* Disallow temp vars at this level. */
2784 current_binding_level
->prep_state
= 2;
2786 /* Make local var to hold return type for multi-type master fn. */
2790 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2792 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2793 ffecom_multi_type_node_
);
2794 multi_retval
= start_decl (multi_retval
, FALSE
);
2795 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2798 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2800 /* Here we emit the actual code for the entry point. */
2806 tree arglist
= NULL_TREE
;
2807 tree
*plist
= &arglist
;
2813 /* Prepare actual arg list based on master arg list. */
2815 for (list
= ffecom_master_arglist_
;
2817 list
= ffebld_trail (list
))
2819 arg
= ffebld_head (list
);
2820 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2822 s
= ffebld_symter (arg
);
2823 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2824 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2825 actarg
= null_pointer_node
; /* We don't have this arg. */
2827 actarg
= ffesymbol_hook (s
).decl_tree
;
2828 *plist
= build_tree_list (NULL_TREE
, actarg
);
2829 plist
= &TREE_CHAIN (*plist
);
2832 /* This code appends the length arguments for character
2833 variables/arrays. */
2835 for (list
= ffecom_master_arglist_
;
2837 list
= ffebld_trail (list
))
2839 arg
= ffebld_head (list
);
2840 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2842 s
= ffebld_symter (arg
);
2843 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2844 continue; /* Only looking for CHARACTER arguments. */
2845 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2846 continue; /* Only looking for variables and arrays. */
2847 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2848 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2849 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2851 actarg
= ffesymbol_hook (s
).length_tree
;
2852 *plist
= build_tree_list (NULL_TREE
, actarg
);
2853 plist
= &TREE_CHAIN (*plist
);
2856 /* Prepend character-value return info to actual arg list. */
2860 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2861 TREE_CHAIN (prepend
)
2862 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2863 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2867 /* Prepend multi-type return value to actual arg list. */
2872 = build_tree_list (NULL_TREE
,
2873 ffecom_1 (ADDR_EXPR
,
2874 build_pointer_type (TREE_TYPE (multi_retval
)),
2876 TREE_CHAIN (prepend
) = arglist
;
2880 /* Prepend my entry-point number to the actual arg list. */
2882 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2883 TREE_CHAIN (prepend
) = arglist
;
2886 /* Build the call to the master function. */
2888 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2889 call
= ffecom_3s (CALL_EXPR
,
2890 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2891 master_fn
, arglist
, NULL_TREE
);
2893 /* Decide whether the master function is a function or subroutine, and
2894 handle the return value for my entry point. */
2896 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2899 expand_expr_stmt (call
);
2900 expand_null_return ();
2902 else if (multi
&& cmplxfunc
)
2904 expand_expr_stmt (call
);
2906 = ffecom_1 (INDIRECT_REF
,
2907 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2909 result
= ffecom_modify (NULL_TREE
, result
,
2910 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2912 ffecom_multi_fields_
[bt
][kt
]));
2913 expand_expr_stmt (result
);
2914 expand_null_return ();
2918 expand_expr_stmt (call
);
2920 = ffecom_modify (NULL_TREE
, result
,
2921 convert (TREE_TYPE (result
),
2922 ffecom_2 (COMPONENT_REF
,
2923 ffecom_tree_type
[bt
][kt
],
2925 ffecom_multi_fields_
[bt
][kt
])));
2926 expand_return (result
);
2931 = ffecom_1 (INDIRECT_REF
,
2932 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2934 result
= ffecom_modify (NULL_TREE
, result
, call
);
2935 expand_expr_stmt (result
);
2936 expand_null_return ();
2940 result
= ffecom_modify (NULL_TREE
,
2942 convert (TREE_TYPE (result
),
2944 expand_return (result
);
2948 ffecom_end_compstmt ();
2950 finish_function (0);
2952 lineno
= old_lineno
;
2953 input_filename
= old_input_filename
;
2955 ffecom_doing_entry_
= FALSE
;
2959 /* Transform expr into gcc tree with possible destination
2961 Recursive descent on expr while making corresponding tree nodes and
2962 attaching type info and such. If destination supplied and compatible
2963 with temporary that would be made in certain cases, temporary isn't
2964 made, destination used instead, and dest_used flag set TRUE. */
2966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2968 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2969 bool *dest_used
, bool assignp
, bool widenp
)
2974 ffeinfoBasictype bt
;
2977 tree dt
; /* decl_tree for an ffesymbol. */
2978 tree tree_type
, tree_type_x
;
2981 enum tree_code code
;
2983 assert (expr
!= NULL
);
2985 if (dest_used
!= NULL
)
2988 bt
= ffeinfo_basictype (ffebld_info (expr
));
2989 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2990 tree_type
= ffecom_tree_type
[bt
][kt
];
2992 /* Widen integral arithmetic as desired while preserving signedness. */
2993 tree_type_x
= NULL_TREE
;
2994 if (widenp
&& tree_type
2995 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2996 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2997 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2999 switch (ffebld_op (expr
))
3001 case FFEBLD_opACCTER
:
3004 ffebit bits
= ffebld_accter_bits (expr
);
3005 ffetargetOffset source_offset
= 0;
3006 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
3009 assert (dest_offset
== 0
3010 || (bt
== FFEINFO_basictypeCHARACTER
3011 && kt
== FFEINFO_kindtypeCHARACTER1
));
3016 ffebldConstantUnion cu
;
3019 ffebldConstantArray ca
= ffebld_accter (expr
);
3021 ffebit_test (bits
, source_offset
, &value
, &length
);
3027 for (i
= 0; i
< length
; ++i
)
3029 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
3032 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3035 && dest_offset
!= 0)
3036 purpose
= build_int_2 (dest_offset
, 0);
3038 purpose
= NULL_TREE
;
3040 if (list
== NULL_TREE
)
3041 list
= item
= build_tree_list (purpose
, t
);
3044 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
3045 item
= TREE_CHAIN (item
);
3049 source_offset
+= length
;
3050 dest_offset
+= length
;
3054 item
= build_int_2 ((ffebld_accter_size (expr
)
3055 + ffebld_accter_pad (expr
)) - 1, 0);
3056 ffebit_kill (ffebld_accter_bits (expr
));
3057 TREE_TYPE (item
) = ffecom_integer_type_node
;
3061 build_range_type (ffecom_integer_type_node
,
3062 ffecom_integer_zero_node
,
3064 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3065 TREE_CONSTANT (list
) = 1;
3066 TREE_STATIC (list
) = 1;
3069 case FFEBLD_opARRTER
:
3074 if (ffebld_arrter_pad (expr
) == 0)
3078 assert (bt
== FFEINFO_basictypeCHARACTER
3079 && kt
== FFEINFO_kindtypeCHARACTER1
);
3081 /* Becomes PURPOSE first time through loop. */
3082 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3085 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3087 ffebldConstantUnion cu
3088 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3090 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3092 if (list
== NULL_TREE
)
3093 /* Assume item is PURPOSE first time through loop. */
3094 list
= item
= build_tree_list (item
, t
);
3097 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3098 item
= TREE_CHAIN (item
);
3103 item
= build_int_2 ((ffebld_arrter_size (expr
)
3104 + ffebld_arrter_pad (expr
)) - 1, 0);
3105 TREE_TYPE (item
) = ffecom_integer_type_node
;
3109 build_range_type (ffecom_integer_type_node
,
3110 ffecom_integer_zero_node
,
3112 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3113 TREE_CONSTANT (list
) = 1;
3114 TREE_STATIC (list
) = 1;
3117 case FFEBLD_opCONTER
:
3118 assert (ffebld_conter_pad (expr
) == 0);
3120 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3124 case FFEBLD_opSYMTER
:
3125 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3126 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3127 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3128 s
= ffebld_symter (expr
);
3129 t
= ffesymbol_hook (s
).decl_tree
;
3132 { /* ASSIGN'ed-label expr. */
3133 if (ffe_is_ugly_assign ())
3135 /* User explicitly wants ASSIGN'ed variables to be at the same
3136 memory address as the variables when used in non-ASSIGN
3137 contexts. That can make old, arcane, non-standard code
3138 work, but don't try to do it when a pointer wouldn't fit
3139 in the normal variable (take other approach, and warn,
3144 s
= ffecom_sym_transform_ (s
);
3145 t
= ffesymbol_hook (s
).decl_tree
;
3146 assert (t
!= NULL_TREE
);
3149 if (t
== error_mark_node
)
3152 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3153 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3155 if (ffesymbol_hook (s
).addr
)
3156 t
= ffecom_1 (INDIRECT_REF
,
3157 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3161 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3163 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3164 FFEBAD_severityWARNING
);
3165 ffebad_string (ffesymbol_text (s
));
3166 ffebad_here (0, ffesymbol_where_line (s
),
3167 ffesymbol_where_column (s
));
3172 /* Don't use the normal variable's tree for ASSIGN, though mark
3173 it as in the system header (housekeeping). Use an explicit,
3174 specially created sibling that is known to be wide enough
3175 to hold pointers to labels. */
3178 && TREE_CODE (t
) == VAR_DECL
)
3179 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3181 t
= ffesymbol_hook (s
).assign_tree
;
3184 s
= ffecom_sym_transform_assign_ (s
);
3185 t
= ffesymbol_hook (s
).assign_tree
;
3186 assert (t
!= NULL_TREE
);
3193 s
= ffecom_sym_transform_ (s
);
3194 t
= ffesymbol_hook (s
).decl_tree
;
3195 assert (t
!= NULL_TREE
);
3197 if (ffesymbol_hook (s
).addr
)
3198 t
= ffecom_1 (INDIRECT_REF
,
3199 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3203 case FFEBLD_opARRAYREF
:
3204 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3206 case FFEBLD_opUPLUS
:
3207 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3208 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3210 case FFEBLD_opPAREN
:
3211 /* ~~~Make sure Fortran rules respected here */
3212 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3213 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3215 case FFEBLD_opUMINUS
:
3216 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3219 tree_type
= tree_type_x
;
3220 left
= convert (tree_type
, left
);
3222 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3225 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3226 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3229 tree_type
= tree_type_x
;
3230 left
= convert (tree_type
, left
);
3231 right
= convert (tree_type
, right
);
3233 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3235 case FFEBLD_opSUBTRACT
:
3236 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3237 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3240 tree_type
= tree_type_x
;
3241 left
= convert (tree_type
, left
);
3242 right
= convert (tree_type
, right
);
3244 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3246 case FFEBLD_opMULTIPLY
:
3247 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3248 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3251 tree_type
= tree_type_x
;
3252 left
= convert (tree_type
, left
);
3253 right
= convert (tree_type
, right
);
3255 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3257 case FFEBLD_opDIVIDE
:
3258 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3259 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3262 tree_type
= tree_type_x
;
3263 left
= convert (tree_type
, left
);
3264 right
= convert (tree_type
, right
);
3266 return ffecom_tree_divide_ (tree_type
, left
, right
,
3267 dest_tree
, dest
, dest_used
,
3268 ffebld_nonter_hook (expr
));
3270 case FFEBLD_opPOWER
:
3272 ffebld left
= ffebld_left (expr
);
3273 ffebld right
= ffebld_right (expr
);
3275 ffeinfoKindtype rtkt
;
3276 ffeinfoKindtype ltkt
;
3279 switch (ffeinfo_basictype (ffebld_info (right
)))
3282 case FFEINFO_basictypeINTEGER
:
3285 item
= ffecom_expr_power_integer_ (expr
);
3286 if (item
!= NULL_TREE
)
3290 rtkt
= FFEINFO_kindtypeINTEGER1
;
3291 switch (ffeinfo_basictype (ffebld_info (left
)))
3293 case FFEINFO_basictypeINTEGER
:
3294 if ((ffeinfo_kindtype (ffebld_info (left
))
3295 == FFEINFO_kindtypeINTEGER4
)
3296 || (ffeinfo_kindtype (ffebld_info (right
))
3297 == FFEINFO_kindtypeINTEGER4
))
3299 code
= FFECOM_gfrtPOW_QQ
;
3300 ltkt
= FFEINFO_kindtypeINTEGER4
;
3301 rtkt
= FFEINFO_kindtypeINTEGER4
;
3305 code
= FFECOM_gfrtPOW_II
;
3306 ltkt
= FFEINFO_kindtypeINTEGER1
;
3310 case FFEINFO_basictypeREAL
:
3311 if (ffeinfo_kindtype (ffebld_info (left
))
3312 == FFEINFO_kindtypeREAL1
)
3314 code
= FFECOM_gfrtPOW_RI
;
3315 ltkt
= FFEINFO_kindtypeREAL1
;
3319 code
= FFECOM_gfrtPOW_DI
;
3320 ltkt
= FFEINFO_kindtypeREAL2
;
3324 case FFEINFO_basictypeCOMPLEX
:
3325 if (ffeinfo_kindtype (ffebld_info (left
))
3326 == FFEINFO_kindtypeREAL1
)
3328 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3329 ltkt
= FFEINFO_kindtypeREAL1
;
3333 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3334 ltkt
= FFEINFO_kindtypeREAL2
;
3339 assert ("bad pow_*i" == NULL
);
3340 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3341 ltkt
= FFEINFO_kindtypeREAL1
;
3344 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3345 left
= ffeexpr_convert (left
, NULL
, NULL
,
3346 ffeinfo_basictype (ffebld_info (left
)),
3348 FFETARGET_charactersizeNONE
,
3349 FFEEXPR_contextLET
);
3350 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3351 right
= ffeexpr_convert (right
, NULL
, NULL
,
3352 FFEINFO_basictypeINTEGER
,
3354 FFETARGET_charactersizeNONE
,
3355 FFEEXPR_contextLET
);
3358 case FFEINFO_basictypeREAL
:
3359 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3360 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3361 FFEINFO_kindtypeREALDOUBLE
, 0,
3362 FFETARGET_charactersizeNONE
,
3363 FFEEXPR_contextLET
);
3364 if (ffeinfo_kindtype (ffebld_info (right
))
3365 == FFEINFO_kindtypeREAL1
)
3366 right
= ffeexpr_convert (right
, NULL
, NULL
,
3367 FFEINFO_basictypeREAL
,
3368 FFEINFO_kindtypeREALDOUBLE
, 0,
3369 FFETARGET_charactersizeNONE
,
3370 FFEEXPR_contextLET
);
3371 /* We used to call FFECOM_gfrtPOW_DD here,
3372 which passes arguments by reference. */
3373 code
= FFECOM_gfrtL_POW
;
3374 /* Pass arguments by value. */
3378 case FFEINFO_basictypeCOMPLEX
:
3379 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3380 left
= ffeexpr_convert (left
, NULL
, NULL
,
3381 FFEINFO_basictypeCOMPLEX
,
3382 FFEINFO_kindtypeREALDOUBLE
, 0,
3383 FFETARGET_charactersizeNONE
,
3384 FFEEXPR_contextLET
);
3385 if (ffeinfo_kindtype (ffebld_info (right
))
3386 == FFEINFO_kindtypeREAL1
)
3387 right
= ffeexpr_convert (right
, NULL
, NULL
,
3388 FFEINFO_basictypeCOMPLEX
,
3389 FFEINFO_kindtypeREALDOUBLE
, 0,
3390 FFETARGET_charactersizeNONE
,
3391 FFEEXPR_contextLET
);
3392 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3393 ref
= TRUE
; /* Pass arguments by reference. */
3397 assert ("bad pow_x*" == NULL
);
3398 code
= FFECOM_gfrtPOW_II
;
3401 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3402 ffecom_gfrt_kindtype (code
),
3403 (ffe_is_f2c_library ()
3404 && ffecom_gfrt_complex_
[code
]),
3405 tree_type
, left
, right
,
3406 dest_tree
, dest
, dest_used
,
3407 NULL_TREE
, FALSE
, ref
,
3408 ffebld_nonter_hook (expr
));
3414 case FFEINFO_basictypeLOGICAL
:
3415 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3416 return convert (tree_type
, item
);
3418 case FFEINFO_basictypeINTEGER
:
3419 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3420 ffecom_expr (ffebld_left (expr
)));
3423 assert ("NOT bad basictype" == NULL
);
3425 case FFEINFO_basictypeANY
:
3426 return error_mark_node
;
3430 case FFEBLD_opFUNCREF
:
3431 assert (ffeinfo_basictype (ffebld_info (expr
))
3432 != FFEINFO_basictypeCHARACTER
);
3434 case FFEBLD_opSUBRREF
:
3435 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3436 == FFEINFO_whereINTRINSIC
)
3437 { /* Invocation of an intrinsic. */
3438 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3442 s
= ffebld_symter (ffebld_left (expr
));
3443 dt
= ffesymbol_hook (s
).decl_tree
;
3444 if (dt
== NULL_TREE
)
3446 s
= ffecom_sym_transform_ (s
);
3447 dt
= ffesymbol_hook (s
).decl_tree
;
3449 if (dt
== error_mark_node
)
3452 if (ffesymbol_hook (s
).addr
)
3455 item
= ffecom_1_fn (dt
);
3457 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3458 args
= ffecom_list_expr (ffebld_right (expr
));
3460 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3462 if (args
== error_mark_node
)
3463 return error_mark_node
;
3465 item
= ffecom_call_ (item
, kt
,
3466 ffesymbol_is_f2c (s
)
3467 && (bt
== FFEINFO_basictypeCOMPLEX
)
3468 && (ffesymbol_where (s
)
3469 != FFEINFO_whereCONSTANT
),
3472 dest_tree
, dest
, dest_used
,
3473 error_mark_node
, FALSE
,
3474 ffebld_nonter_hook (expr
));
3475 TREE_SIDE_EFFECTS (item
) = 1;
3481 case FFEINFO_basictypeLOGICAL
:
3483 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3484 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3485 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3486 return convert (tree_type
, item
);
3488 case FFEINFO_basictypeINTEGER
:
3489 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3490 ffecom_expr (ffebld_left (expr
)),
3491 ffecom_expr (ffebld_right (expr
)));
3494 assert ("AND bad basictype" == NULL
);
3496 case FFEINFO_basictypeANY
:
3497 return error_mark_node
;
3504 case FFEINFO_basictypeLOGICAL
:
3506 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3507 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3508 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3509 return convert (tree_type
, item
);
3511 case FFEINFO_basictypeINTEGER
:
3512 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3513 ffecom_expr (ffebld_left (expr
)),
3514 ffecom_expr (ffebld_right (expr
)));
3517 assert ("OR bad basictype" == NULL
);
3519 case FFEINFO_basictypeANY
:
3520 return error_mark_node
;
3528 case FFEINFO_basictypeLOGICAL
:
3530 = ffecom_2 (NE_EXPR
, integer_type_node
,
3531 ffecom_expr (ffebld_left (expr
)),
3532 ffecom_expr (ffebld_right (expr
)));
3533 return convert (tree_type
, ffecom_truth_value (item
));
3535 case FFEINFO_basictypeINTEGER
:
3536 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3537 ffecom_expr (ffebld_left (expr
)),
3538 ffecom_expr (ffebld_right (expr
)));
3541 assert ("XOR/NEQV bad basictype" == NULL
);
3543 case FFEINFO_basictypeANY
:
3544 return error_mark_node
;
3551 case FFEINFO_basictypeLOGICAL
:
3553 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3554 ffecom_expr (ffebld_left (expr
)),
3555 ffecom_expr (ffebld_right (expr
)));
3556 return convert (tree_type
, ffecom_truth_value (item
));
3558 case FFEINFO_basictypeINTEGER
:
3560 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3561 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3562 ffecom_expr (ffebld_left (expr
)),
3563 ffecom_expr (ffebld_right (expr
))));
3566 assert ("EQV bad basictype" == NULL
);
3568 case FFEINFO_basictypeANY
:
3569 return error_mark_node
;
3573 case FFEBLD_opCONVERT
:
3574 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3575 return error_mark_node
;
3579 case FFEINFO_basictypeLOGICAL
:
3580 case FFEINFO_basictypeINTEGER
:
3581 case FFEINFO_basictypeREAL
:
3582 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3584 case FFEINFO_basictypeCOMPLEX
:
3585 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3587 case FFEINFO_basictypeINTEGER
:
3588 case FFEINFO_basictypeLOGICAL
:
3589 case FFEINFO_basictypeREAL
:
3590 item
= ffecom_expr (ffebld_left (expr
));
3591 if (item
== error_mark_node
)
3592 return error_mark_node
;
3593 /* convert() takes care of converting to the subtype first,
3594 at least in gcc-2.7.2. */
3595 item
= convert (tree_type
, item
);
3598 case FFEINFO_basictypeCOMPLEX
:
3599 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3602 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3604 case FFEINFO_basictypeANY
:
3605 return error_mark_node
;
3610 assert ("CONVERT bad basictype" == NULL
);
3612 case FFEINFO_basictypeANY
:
3613 return error_mark_node
;
3619 goto relational
; /* :::::::::::::::::::: */
3623 goto relational
; /* :::::::::::::::::::: */
3627 goto relational
; /* :::::::::::::::::::: */
3631 goto relational
; /* :::::::::::::::::::: */
3635 goto relational
; /* :::::::::::::::::::: */
3640 relational
: /* :::::::::::::::::::: */
3641 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3643 case FFEINFO_basictypeLOGICAL
:
3644 case FFEINFO_basictypeINTEGER
:
3645 case FFEINFO_basictypeREAL
:
3646 item
= ffecom_2 (code
, integer_type_node
,
3647 ffecom_expr (ffebld_left (expr
)),
3648 ffecom_expr (ffebld_right (expr
)));
3649 return convert (tree_type
, item
);
3651 case FFEINFO_basictypeCOMPLEX
:
3652 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3655 tree arg1
= ffecom_expr (ffebld_left (expr
));
3656 tree arg2
= ffecom_expr (ffebld_right (expr
));
3658 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3659 return error_mark_node
;
3661 arg1
= ffecom_save_tree (arg1
);
3662 arg2
= ffecom_save_tree (arg2
);
3664 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3666 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3667 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3671 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3672 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3676 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3677 ffecom_2 (EQ_EXPR
, integer_type_node
,
3678 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3679 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3680 ffecom_2 (EQ_EXPR
, integer_type_node
,
3681 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3682 ffecom_1 (IMAGPART_EXPR
, real_type
,
3684 if (code
== EQ_EXPR
)
3685 item
= ffecom_truth_value (item
);
3687 item
= ffecom_truth_value_invert (item
);
3688 return convert (tree_type
, item
);
3691 case FFEINFO_basictypeCHARACTER
:
3693 ffebld left
= ffebld_left (expr
);
3694 ffebld right
= ffebld_right (expr
);
3700 /* f2c run-time functions do the implicit blank-padding for us,
3701 so we don't usually have to implement blank-padding ourselves.
3702 (The exception is when we pass an argument to a separately
3703 compiled statement function -- if we know the arg is not the
3704 same length as the dummy, we must truncate or extend it. If
3705 we "inline" statement functions, that necessity goes away as
3708 Strip off the CONVERT operators that blank-pad. (Truncation by
3709 CONVERT shouldn't happen here, but it can happen in
3712 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3713 left
= ffebld_left (left
);
3714 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3715 right
= ffebld_left (right
);
3717 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3718 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3720 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3721 || right_tree
== error_mark_node
3722 || right_length
== error_mark_node
)
3723 return error_mark_node
;
3725 if ((ffebld_size_known (left
) == 1)
3726 && (ffebld_size_known (right
) == 1))
3729 = ffecom_1 (INDIRECT_REF
,
3730 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3733 = ffecom_1 (INDIRECT_REF
,
3734 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3738 = ffecom_2 (code
, integer_type_node
,
3739 ffecom_2 (ARRAY_REF
,
3740 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3743 ffecom_2 (ARRAY_REF
,
3744 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3750 item
= build_tree_list (NULL_TREE
, left_tree
);
3751 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3752 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3754 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3755 = build_tree_list (NULL_TREE
, right_length
);
3756 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3757 item
= ffecom_2 (code
, integer_type_node
,
3759 convert (TREE_TYPE (item
),
3760 integer_zero_node
));
3762 item
= convert (tree_type
, item
);
3768 assert ("relational bad basictype" == NULL
);
3770 case FFEINFO_basictypeANY
:
3771 return error_mark_node
;
3775 case FFEBLD_opPERCENT_LOC
:
3776 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3777 return convert (tree_type
, item
);
3781 case FFEBLD_opBOUNDS
:
3782 case FFEBLD_opREPEAT
:
3783 case FFEBLD_opLABTER
:
3784 case FFEBLD_opLABTOK
:
3785 case FFEBLD_opIMPDO
:
3786 case FFEBLD_opCONCATENATE
:
3787 case FFEBLD_opSUBSTR
:
3789 assert ("bad op" == NULL
);
3792 return error_mark_node
;
3796 assert ("didn't think anything got here anymore!!" == NULL
);
3798 switch (ffebld_arity (expr
))
3801 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3802 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3803 if (TREE_OPERAND (item
, 0) == error_mark_node
3804 || TREE_OPERAND (item
, 1) == error_mark_node
)
3805 return error_mark_node
;
3809 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3810 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3811 return error_mark_node
;
3823 /* Returns the tree that does the intrinsic invocation.
3825 Note: this function applies only to intrinsics returning
3826 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3829 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3831 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3832 ffebld dest
, bool *dest_used
)
3835 tree saved_expr1
; /* For those who need it. */
3836 tree saved_expr2
; /* For those who need it. */
3837 ffeinfoBasictype bt
;
3841 tree real_type
; /* REAL type corresponding to COMPLEX. */
3843 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3844 ffebld arg1
; /* For handy reference. */
3847 ffeintrinImp codegen_imp
;
3850 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3852 if (dest_used
!= NULL
)
3855 bt
= ffeinfo_basictype (ffebld_info (expr
));
3856 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3857 tree_type
= ffecom_tree_type
[bt
][kt
];
3861 arg1
= ffebld_head (list
);
3862 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3863 return error_mark_node
;
3864 if ((list
= ffebld_trail (list
)) != NULL
)
3866 arg2
= ffebld_head (list
);
3867 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3868 return error_mark_node
;
3869 if ((list
= ffebld_trail (list
)) != NULL
)
3871 arg3
= ffebld_head (list
);
3872 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3873 return error_mark_node
;
3882 arg1
= arg2
= arg3
= NULL
;
3884 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3885 args. This is used by the MAX/MIN expansions. */
3888 arg1_type
= ffecom_tree_type
3889 [ffeinfo_basictype (ffebld_info (arg1
))]
3890 [ffeinfo_kindtype (ffebld_info (arg1
))];
3892 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3895 /* There are several ways for each of the cases in the following switch
3896 statements to exit (from simplest to use to most complicated):
3898 break; (when expr_tree == NULL)
3900 A standard call is made to the specific intrinsic just as if it had been
3901 passed in as a dummy procedure and called as any old procedure. This
3902 method can produce slower code but in some cases it's the easiest way for
3903 now. However, if a (presumably faster) direct call is available,
3904 that is used, so this is the easiest way in many more cases now.
3906 gfrt = FFECOM_gfrtWHATEVER;
3909 gfrt contains the gfrt index of a library function to call, passing the
3910 argument(s) by value rather than by reference. Used when a more
3911 careful choice of library function is needed than that provided
3912 by the vanilla `break;'.
3916 The expr_tree has been completely set up and is ready to be returned
3917 as is. No further actions are taken. Use this when the tree is not
3918 in the simple form for one of the arity_n labels. */
3920 /* For info on how the switch statement cases were written, see the files
3921 enclosed in comments below the switch statement. */
3923 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3924 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3925 if (gfrt
== FFECOM_gfrt
)
3926 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3928 switch (codegen_imp
)
3930 case FFEINTRIN_impABS
:
3931 case FFEINTRIN_impCABS
:
3932 case FFEINTRIN_impCDABS
:
3933 case FFEINTRIN_impDABS
:
3934 case FFEINTRIN_impIABS
:
3935 if (ffeinfo_basictype (ffebld_info (arg1
))
3936 == FFEINFO_basictypeCOMPLEX
)
3938 if (kt
== FFEINFO_kindtypeREAL1
)
3939 gfrt
= FFECOM_gfrtCABS
;
3940 else if (kt
== FFEINFO_kindtypeREAL2
)
3941 gfrt
= FFECOM_gfrtCDABS
;
3944 return ffecom_1 (ABS_EXPR
, tree_type
,
3945 convert (tree_type
, ffecom_expr (arg1
)));
3947 case FFEINTRIN_impACOS
:
3948 case FFEINTRIN_impDACOS
:
3951 case FFEINTRIN_impAIMAG
:
3952 case FFEINTRIN_impDIMAG
:
3953 case FFEINTRIN_impIMAGPART
:
3954 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3955 arg1_type
= TREE_TYPE (arg1_type
);
3957 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3961 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3962 ffecom_expr (arg1
)));
3964 case FFEINTRIN_impAINT
:
3965 case FFEINTRIN_impDINT
:
3967 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3968 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3969 #else /* in the meantime, must use floor to avoid range problems with ints */
3970 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3971 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3974 ffecom_3 (COND_EXPR
, double_type_node
,
3976 (ffecom_2 (GE_EXPR
, integer_type_node
,
3979 ffecom_float_zero_
))),
3980 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3981 build_tree_list (NULL_TREE
,
3982 convert (double_type_node
,
3985 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3986 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3987 build_tree_list (NULL_TREE
,
3988 convert (double_type_node
,
3989 ffecom_1 (NEGATE_EXPR
,
3997 case FFEINTRIN_impANINT
:
3998 case FFEINTRIN_impDNINT
:
3999 #if 0 /* This way of doing it won't handle real
4000 numbers of large magnitudes. */
4001 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4002 expr_tree
= convert (tree_type
,
4003 convert (integer_type_node
,
4004 ffecom_3 (COND_EXPR
, tree_type
,
4009 ffecom_float_zero_
)),
4010 ffecom_2 (PLUS_EXPR
,
4013 ffecom_float_half_
),
4014 ffecom_2 (MINUS_EXPR
,
4017 ffecom_float_half_
))));
4019 #else /* So we instead call floor. */
4020 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4021 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4024 ffecom_3 (COND_EXPR
, double_type_node
,
4026 (ffecom_2 (GE_EXPR
, integer_type_node
,
4029 ffecom_float_zero_
))),
4030 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4031 build_tree_list (NULL_TREE
,
4032 convert (double_type_node
,
4033 ffecom_2 (PLUS_EXPR
,
4037 ffecom_float_half_
)))),
4039 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4040 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4041 build_tree_list (NULL_TREE
,
4042 convert (double_type_node
,
4043 ffecom_2 (MINUS_EXPR
,
4046 ffecom_float_half_
),
4053 case FFEINTRIN_impASIN
:
4054 case FFEINTRIN_impDASIN
:
4055 case FFEINTRIN_impATAN
:
4056 case FFEINTRIN_impDATAN
:
4057 case FFEINTRIN_impATAN2
:
4058 case FFEINTRIN_impDATAN2
:
4061 case FFEINTRIN_impCHAR
:
4062 case FFEINTRIN_impACHAR
:
4064 tempvar
= ffecom_make_tempvar (char_type_node
, 1, -1);
4066 tempvar
= ffebld_nonter_hook (expr
);
4070 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4072 expr_tree
= ffecom_modify (tmv
,
4073 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4075 convert (tmv
, ffecom_expr (arg1
)));
4077 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4080 expr_tree
= ffecom_1 (ADDR_EXPR
,
4081 build_pointer_type (TREE_TYPE (expr_tree
)),
4085 case FFEINTRIN_impCMPLX
:
4086 case FFEINTRIN_impDCMPLX
:
4089 convert (tree_type
, ffecom_expr (arg1
));
4091 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4093 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4094 convert (real_type
, ffecom_expr (arg1
)),
4096 ffecom_expr (arg2
)));
4098 case FFEINTRIN_impCOMPLEX
:
4100 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4102 ffecom_expr (arg2
));
4104 case FFEINTRIN_impCONJG
:
4105 case FFEINTRIN_impDCONJG
:
4109 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4110 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4112 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4113 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4114 ffecom_1 (NEGATE_EXPR
, real_type
,
4115 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4118 case FFEINTRIN_impCOS
:
4119 case FFEINTRIN_impCCOS
:
4120 case FFEINTRIN_impCDCOS
:
4121 case FFEINTRIN_impDCOS
:
4122 if (bt
== FFEINFO_basictypeCOMPLEX
)
4124 if (kt
== FFEINFO_kindtypeREAL1
)
4125 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4126 else if (kt
== FFEINFO_kindtypeREAL2
)
4127 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4131 case FFEINTRIN_impCOSH
:
4132 case FFEINTRIN_impDCOSH
:
4135 case FFEINTRIN_impDBLE
:
4136 case FFEINTRIN_impDFLOAT
:
4137 case FFEINTRIN_impDREAL
:
4138 case FFEINTRIN_impFLOAT
:
4139 case FFEINTRIN_impIDINT
:
4140 case FFEINTRIN_impIFIX
:
4141 case FFEINTRIN_impINT2
:
4142 case FFEINTRIN_impINT8
:
4143 case FFEINTRIN_impINT
:
4144 case FFEINTRIN_impLONG
:
4145 case FFEINTRIN_impREAL
:
4146 case FFEINTRIN_impSHORT
:
4147 case FFEINTRIN_impSNGL
:
4148 return convert (tree_type
, ffecom_expr (arg1
));
4150 case FFEINTRIN_impDIM
:
4151 case FFEINTRIN_impDDIM
:
4152 case FFEINTRIN_impIDIM
:
4153 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4154 ffecom_expr (arg1
)));
4155 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4156 ffecom_expr (arg2
)));
4158 ffecom_3 (COND_EXPR
, tree_type
,
4160 (ffecom_2 (GT_EXPR
, integer_type_node
,
4163 ffecom_2 (MINUS_EXPR
, tree_type
,
4166 convert (tree_type
, ffecom_float_zero_
));
4168 case FFEINTRIN_impDPROD
:
4170 ffecom_2 (MULT_EXPR
, tree_type
,
4171 convert (tree_type
, ffecom_expr (arg1
)),
4172 convert (tree_type
, ffecom_expr (arg2
)));
4174 case FFEINTRIN_impEXP
:
4175 case FFEINTRIN_impCDEXP
:
4176 case FFEINTRIN_impCEXP
:
4177 case FFEINTRIN_impDEXP
:
4178 if (bt
== FFEINFO_basictypeCOMPLEX
)
4180 if (kt
== FFEINFO_kindtypeREAL1
)
4181 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4182 else if (kt
== FFEINFO_kindtypeREAL2
)
4183 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4187 case FFEINTRIN_impICHAR
:
4188 case FFEINTRIN_impIACHAR
:
4189 #if 0 /* The simple approach. */
4190 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4192 = ffecom_1 (INDIRECT_REF
,
4193 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4196 = ffecom_2 (ARRAY_REF
,
4197 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4200 return convert (tree_type
, expr_tree
);
4201 #else /* The more interesting (and more optimal) approach. */
4202 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4203 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4206 convert (tree_type
, integer_zero_node
));
4210 case FFEINTRIN_impINDEX
:
4213 case FFEINTRIN_impLEN
:
4215 break; /* The simple approach. */
4217 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4220 case FFEINTRIN_impLGE
:
4221 case FFEINTRIN_impLGT
:
4222 case FFEINTRIN_impLLE
:
4223 case FFEINTRIN_impLLT
:
4226 case FFEINTRIN_impLOG
:
4227 case FFEINTRIN_impALOG
:
4228 case FFEINTRIN_impCDLOG
:
4229 case FFEINTRIN_impCLOG
:
4230 case FFEINTRIN_impDLOG
:
4231 if (bt
== FFEINFO_basictypeCOMPLEX
)
4233 if (kt
== FFEINFO_kindtypeREAL1
)
4234 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4235 else if (kt
== FFEINFO_kindtypeREAL2
)
4236 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4240 case FFEINTRIN_impLOG10
:
4241 case FFEINTRIN_impALOG10
:
4242 case FFEINTRIN_impDLOG10
:
4243 if (gfrt
!= FFECOM_gfrt
)
4244 break; /* Already picked one, stick with it. */
4246 if (kt
== FFEINFO_kindtypeREAL1
)
4247 /* We used to call FFECOM_gfrtALOG10 here. */
4248 gfrt
= FFECOM_gfrtL_LOG10
;
4249 else if (kt
== FFEINFO_kindtypeREAL2
)
4250 /* We used to call FFECOM_gfrtDLOG10 here. */
4251 gfrt
= FFECOM_gfrtL_LOG10
;
4254 case FFEINTRIN_impMAX
:
4255 case FFEINTRIN_impAMAX0
:
4256 case FFEINTRIN_impAMAX1
:
4257 case FFEINTRIN_impDMAX1
:
4258 case FFEINTRIN_impMAX0
:
4259 case FFEINTRIN_impMAX1
:
4260 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4261 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4263 arg1_type
= tree_type
;
4264 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4265 convert (arg1_type
, ffecom_expr (arg1
)),
4266 convert (arg1_type
, ffecom_expr (arg2
)));
4267 for (; list
!= NULL
; list
= ffebld_trail (list
))
4269 if ((ffebld_head (list
) == NULL
)
4270 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4272 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4275 ffecom_expr (ffebld_head (list
))));
4277 return convert (tree_type
, expr_tree
);
4279 case FFEINTRIN_impMIN
:
4280 case FFEINTRIN_impAMIN0
:
4281 case FFEINTRIN_impAMIN1
:
4282 case FFEINTRIN_impDMIN1
:
4283 case FFEINTRIN_impMIN0
:
4284 case FFEINTRIN_impMIN1
:
4285 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4286 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4288 arg1_type
= tree_type
;
4289 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4290 convert (arg1_type
, ffecom_expr (arg1
)),
4291 convert (arg1_type
, ffecom_expr (arg2
)));
4292 for (; list
!= NULL
; list
= ffebld_trail (list
))
4294 if ((ffebld_head (list
) == NULL
)
4295 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4297 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4300 ffecom_expr (ffebld_head (list
))));
4302 return convert (tree_type
, expr_tree
);
4304 case FFEINTRIN_impMOD
:
4305 case FFEINTRIN_impAMOD
:
4306 case FFEINTRIN_impDMOD
:
4307 if (bt
!= FFEINFO_basictypeREAL
)
4308 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4309 convert (tree_type
, ffecom_expr (arg1
)),
4310 convert (tree_type
, ffecom_expr (arg2
)));
4312 if (kt
== FFEINFO_kindtypeREAL1
)
4313 /* We used to call FFECOM_gfrtAMOD here. */
4314 gfrt
= FFECOM_gfrtL_FMOD
;
4315 else if (kt
== FFEINFO_kindtypeREAL2
)
4316 /* We used to call FFECOM_gfrtDMOD here. */
4317 gfrt
= FFECOM_gfrtL_FMOD
;
4320 case FFEINTRIN_impNINT
:
4321 case FFEINTRIN_impIDNINT
:
4323 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4324 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4326 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4327 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4329 convert (ffecom_integer_type_node
,
4330 ffecom_3 (COND_EXPR
, arg1_type
,
4332 (ffecom_2 (GE_EXPR
, integer_type_node
,
4335 ffecom_float_zero_
))),
4336 ffecom_2 (PLUS_EXPR
, arg1_type
,
4339 ffecom_float_half_
)),
4340 ffecom_2 (MINUS_EXPR
, arg1_type
,
4343 ffecom_float_half_
))));
4346 case FFEINTRIN_impSIGN
:
4347 case FFEINTRIN_impDSIGN
:
4348 case FFEINTRIN_impISIGN
:
4350 tree arg2_tree
= ffecom_expr (arg2
);
4354 (ffecom_1 (ABS_EXPR
, tree_type
,
4356 ffecom_expr (arg1
))));
4358 = ffecom_3 (COND_EXPR
, tree_type
,
4360 (ffecom_2 (GE_EXPR
, integer_type_node
,
4362 convert (TREE_TYPE (arg2_tree
),
4363 integer_zero_node
))),
4365 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4366 /* Make sure SAVE_EXPRs get referenced early enough. */
4368 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4369 convert (void_type_node
, saved_expr1
),
4374 case FFEINTRIN_impSIN
:
4375 case FFEINTRIN_impCDSIN
:
4376 case FFEINTRIN_impCSIN
:
4377 case FFEINTRIN_impDSIN
:
4378 if (bt
== FFEINFO_basictypeCOMPLEX
)
4380 if (kt
== FFEINFO_kindtypeREAL1
)
4381 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4382 else if (kt
== FFEINFO_kindtypeREAL2
)
4383 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4387 case FFEINTRIN_impSINH
:
4388 case FFEINTRIN_impDSINH
:
4391 case FFEINTRIN_impSQRT
:
4392 case FFEINTRIN_impCDSQRT
:
4393 case FFEINTRIN_impCSQRT
:
4394 case FFEINTRIN_impDSQRT
:
4395 if (bt
== FFEINFO_basictypeCOMPLEX
)
4397 if (kt
== FFEINFO_kindtypeREAL1
)
4398 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4399 else if (kt
== FFEINFO_kindtypeREAL2
)
4400 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4404 case FFEINTRIN_impTAN
:
4405 case FFEINTRIN_impDTAN
:
4406 case FFEINTRIN_impTANH
:
4407 case FFEINTRIN_impDTANH
:
4410 case FFEINTRIN_impREALPART
:
4411 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4412 arg1_type
= TREE_TYPE (arg1_type
);
4414 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4418 ffecom_1 (REALPART_EXPR
, arg1_type
,
4419 ffecom_expr (arg1
)));
4421 case FFEINTRIN_impIAND
:
4422 case FFEINTRIN_impAND
:
4423 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4425 ffecom_expr (arg1
)),
4427 ffecom_expr (arg2
)));
4429 case FFEINTRIN_impIOR
:
4430 case FFEINTRIN_impOR
:
4431 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4433 ffecom_expr (arg1
)),
4435 ffecom_expr (arg2
)));
4437 case FFEINTRIN_impIEOR
:
4438 case FFEINTRIN_impXOR
:
4439 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4441 ffecom_expr (arg1
)),
4443 ffecom_expr (arg2
)));
4445 case FFEINTRIN_impLSHIFT
:
4446 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4448 convert (integer_type_node
,
4449 ffecom_expr (arg2
)));
4451 case FFEINTRIN_impRSHIFT
:
4452 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4454 convert (integer_type_node
,
4455 ffecom_expr (arg2
)));
4457 case FFEINTRIN_impNOT
:
4458 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4460 case FFEINTRIN_impBIT_SIZE
:
4461 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4463 case FFEINTRIN_impBTEST
:
4465 ffetargetLogical1 target_true
;
4466 ffetargetLogical1 target_false
;
4470 ffetarget_logical1 (&target_true
, TRUE
);
4471 ffetarget_logical1 (&target_false
, FALSE
);
4472 if (target_true
== 1)
4473 true_tree
= convert (tree_type
, integer_one_node
);
4475 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4476 if (target_false
== 0)
4477 false_tree
= convert (tree_type
, integer_zero_node
);
4479 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4482 ffecom_3 (COND_EXPR
, tree_type
,
4484 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4485 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4487 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4490 convert (integer_type_node
,
4491 ffecom_expr (arg2
)))),
4493 integer_zero_node
))),
4498 case FFEINTRIN_impIBCLR
:
4500 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4502 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4503 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4506 convert (integer_type_node
,
4507 ffecom_expr (arg2
)))));
4509 case FFEINTRIN_impIBITS
:
4511 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4512 ffecom_expr (arg3
)));
4514 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4517 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4518 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4520 convert (integer_type_node
,
4521 ffecom_expr (arg2
))),
4523 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4524 ffecom_1 (BIT_NOT_EXPR
,
4527 integer_zero_node
)),
4528 ffecom_2 (MINUS_EXPR
,
4530 TYPE_SIZE (uns_type
),
4532 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4534 = ffecom_3 (COND_EXPR
, tree_type
,
4536 (ffecom_2 (NE_EXPR
, integer_type_node
,
4538 integer_zero_node
)),
4540 convert (tree_type
, integer_zero_node
));
4545 case FFEINTRIN_impIBSET
:
4547 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4549 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4550 convert (tree_type
, integer_one_node
),
4551 convert (integer_type_node
,
4552 ffecom_expr (arg2
))));
4554 case FFEINTRIN_impISHFT
:
4556 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4557 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4558 ffecom_expr (arg2
)));
4560 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4563 = ffecom_3 (COND_EXPR
, tree_type
,
4565 (ffecom_2 (GE_EXPR
, integer_type_node
,
4567 integer_zero_node
)),
4568 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4572 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4573 convert (uns_type
, arg1_tree
),
4574 ffecom_1 (NEGATE_EXPR
,
4577 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4579 = ffecom_3 (COND_EXPR
, tree_type
,
4581 (ffecom_2 (NE_EXPR
, integer_type_node
,
4583 TYPE_SIZE (uns_type
))),
4585 convert (tree_type
, integer_zero_node
));
4587 /* Make sure SAVE_EXPRs get referenced early enough. */
4589 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4590 convert (void_type_node
, arg1_tree
),
4591 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4592 convert (void_type_node
, arg2_tree
),
4597 case FFEINTRIN_impISHFTC
:
4599 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4600 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4601 ffecom_expr (arg2
)));
4602 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4603 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4609 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4612 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4613 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4614 convert (tree_type
, integer_zero_node
)),
4616 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4618 = ffecom_3 (COND_EXPR
, tree_type
,
4620 (ffecom_2 (NE_EXPR
, integer_type_node
,
4622 TYPE_SIZE (uns_type
))),
4624 convert (tree_type
, integer_zero_node
));
4626 mask_arg1
= ffecom_save_tree (mask_arg1
);
4628 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4630 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4632 masked_arg1
= ffecom_save_tree (masked_arg1
);
4634 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4636 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4637 convert (uns_type
, masked_arg1
),
4638 ffecom_1 (NEGATE_EXPR
,
4641 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4643 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4647 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4648 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4652 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4653 convert (uns_type
, masked_arg1
),
4654 ffecom_2 (MINUS_EXPR
,
4659 = ffecom_3 (COND_EXPR
, tree_type
,
4661 (ffecom_2 (LT_EXPR
, integer_type_node
,
4663 integer_zero_node
)),
4667 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4668 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4671 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4672 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4676 = ffecom_3 (COND_EXPR
, tree_type
,
4678 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4679 ffecom_2 (EQ_EXPR
, integer_type_node
,
4684 ffecom_2 (EQ_EXPR
, integer_type_node
,
4686 integer_zero_node
))),
4689 /* Make sure SAVE_EXPRs get referenced early enough. */
4691 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4692 convert (void_type_node
, arg1_tree
),
4693 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4694 convert (void_type_node
, arg2_tree
),
4695 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4696 convert (void_type_node
,
4698 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4699 convert (void_type_node
,
4703 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4704 convert (void_type_node
,
4710 case FFEINTRIN_impLOC
:
4712 tree arg1_tree
= ffecom_expr (arg1
);
4715 = convert (tree_type
,
4716 ffecom_1 (ADDR_EXPR
,
4717 build_pointer_type (TREE_TYPE (arg1_tree
)),
4722 case FFEINTRIN_impMVBITS
:
4727 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4730 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4734 tree arg5_plus_arg3
;
4736 arg2_tree
= convert (integer_type_node
,
4737 ffecom_expr (arg2
));
4738 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4739 ffecom_expr (arg3
)));
4740 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4741 arg4_type
= TREE_TYPE (arg4_tree
);
4743 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4744 ffecom_expr (arg1
)));
4746 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4747 ffecom_expr (arg5
)));
4750 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4751 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4752 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4755 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4756 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4757 ffecom_1 (BIT_NOT_EXPR
,
4761 integer_zero_node
)),
4765 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4769 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4770 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4772 integer_zero_node
)),
4774 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4776 = ffecom_3 (COND_EXPR
, arg4_type
,
4778 (ffecom_2 (NE_EXPR
, integer_type_node
,
4780 convert (TREE_TYPE (arg5_plus_arg3
),
4781 TYPE_SIZE (arg4_type
)))),
4783 convert (arg4_type
, integer_zero_node
));
4786 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4788 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4790 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4791 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4792 ffecom_1 (BIT_NOT_EXPR
,
4796 integer_zero_node
)),
4799 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4802 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4804 = ffecom_3 (COND_EXPR
, arg4_type
,
4806 (ffecom_2 (NE_EXPR
, integer_type_node
,
4808 convert (TREE_TYPE (arg3_tree
),
4809 integer_zero_node
))),
4813 = ffecom_3 (COND_EXPR
, arg4_type
,
4815 (ffecom_2 (NE_EXPR
, integer_type_node
,
4817 convert (TREE_TYPE (arg3_tree
),
4818 TYPE_SIZE (arg4_type
)))),
4823 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4826 /* Make sure SAVE_EXPRs get referenced early enough. */
4828 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4830 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4832 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4834 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4838 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4845 case FFEINTRIN_impDERF
:
4846 case FFEINTRIN_impERF
:
4847 case FFEINTRIN_impDERFC
:
4848 case FFEINTRIN_impERFC
:
4851 case FFEINTRIN_impIARGC
:
4852 /* extern int xargc; i__1 = xargc - 1; */
4853 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4855 convert (TREE_TYPE (ffecom_tree_xargc_
),
4859 case FFEINTRIN_impSIGNAL_func
:
4860 case FFEINTRIN_impSIGNAL_subr
:
4866 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4867 ffecom_expr (arg1
));
4868 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4869 build_pointer_type (TREE_TYPE (arg1_tree
)),
4872 /* Pass procedure as a pointer to it, anything else by value. */
4873 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4874 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4876 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4877 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4881 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4883 arg3_tree
= NULL_TREE
;
4885 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4886 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4887 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4890 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4891 ffecom_gfrt_kindtype (gfrt
),
4893 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
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_impALARM
:
4914 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4915 ffecom_expr (arg1
));
4916 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4917 build_pointer_type (TREE_TYPE (arg1_tree
)),
4920 /* Pass procedure as a pointer to it, anything else by value. */
4921 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4922 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4924 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4925 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4929 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4931 arg3_tree
= NULL_TREE
;
4933 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4934 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4935 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4938 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4939 ffecom_gfrt_kindtype (gfrt
),
4943 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4944 ffebld_nonter_hook (expr
));
4946 if (arg3_tree
!= NULL_TREE
)
4948 = ffecom_modify (NULL_TREE
, arg3_tree
,
4949 convert (TREE_TYPE (arg3_tree
),
4954 case FFEINTRIN_impCHDIR_subr
:
4955 case FFEINTRIN_impFDATE_subr
:
4956 case FFEINTRIN_impFGET_subr
:
4957 case FFEINTRIN_impFPUT_subr
:
4958 case FFEINTRIN_impGETCWD_subr
:
4959 case FFEINTRIN_impHOSTNM_subr
:
4960 case FFEINTRIN_impSYSTEM_subr
:
4961 case FFEINTRIN_impUNLINK_subr
:
4963 tree arg1_len
= integer_zero_node
;
4967 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4970 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4972 arg2_tree
= NULL_TREE
;
4974 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4975 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4976 TREE_CHAIN (arg1_tree
) = arg1_len
;
4979 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4980 ffecom_gfrt_kindtype (gfrt
),
4984 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4985 ffebld_nonter_hook (expr
));
4987 if (arg2_tree
!= NULL_TREE
)
4989 = ffecom_modify (NULL_TREE
, arg2_tree
,
4990 convert (TREE_TYPE (arg2_tree
),
4995 case FFEINTRIN_impEXIT
:
4999 expr_tree
= build_tree_list (NULL_TREE
,
5000 ffecom_1 (ADDR_EXPR
,
5002 (ffecom_integer_type_node
),
5003 integer_zero_node
));
5006 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5007 ffecom_gfrt_kindtype (gfrt
),
5011 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5012 ffebld_nonter_hook (expr
));
5014 case FFEINTRIN_impFLUSH
:
5016 gfrt
= FFECOM_gfrtFLUSH
;
5018 gfrt
= FFECOM_gfrtFLUSH1
;
5021 case FFEINTRIN_impCHMOD_subr
:
5022 case FFEINTRIN_impLINK_subr
:
5023 case FFEINTRIN_impRENAME_subr
:
5024 case FFEINTRIN_impSYMLNK_subr
:
5026 tree arg1_len
= integer_zero_node
;
5028 tree arg2_len
= integer_zero_node
;
5032 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5033 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5035 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5037 arg3_tree
= NULL_TREE
;
5039 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5040 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5041 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5042 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5043 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5044 TREE_CHAIN (arg2_tree
) = arg1_len
;
5045 TREE_CHAIN (arg1_len
) = arg2_len
;
5046 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5047 ffecom_gfrt_kindtype (gfrt
),
5051 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5052 ffebld_nonter_hook (expr
));
5053 if (arg3_tree
!= NULL_TREE
)
5054 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5055 convert (TREE_TYPE (arg3_tree
),
5060 case FFEINTRIN_impLSTAT_subr
:
5061 case FFEINTRIN_impSTAT_subr
:
5063 tree arg1_len
= integer_zero_node
;
5068 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5070 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5073 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5075 arg3_tree
= NULL_TREE
;
5077 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5078 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5079 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5080 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5081 TREE_CHAIN (arg2_tree
) = arg1_len
;
5082 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5083 ffecom_gfrt_kindtype (gfrt
),
5087 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5088 ffebld_nonter_hook (expr
));
5089 if (arg3_tree
!= NULL_TREE
)
5090 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5091 convert (TREE_TYPE (arg3_tree
),
5096 case FFEINTRIN_impFGETC_subr
:
5097 case FFEINTRIN_impFPUTC_subr
:
5101 tree arg2_len
= integer_zero_node
;
5104 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5105 ffecom_expr (arg1
));
5106 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5107 build_pointer_type (TREE_TYPE (arg1_tree
)),
5110 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5112 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5114 arg3_tree
= NULL_TREE
;
5116 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5117 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5118 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5119 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5120 TREE_CHAIN (arg2_tree
) = arg2_len
;
5122 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5123 ffecom_gfrt_kindtype (gfrt
),
5127 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5128 ffebld_nonter_hook (expr
));
5129 if (arg3_tree
!= NULL_TREE
)
5130 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5131 convert (TREE_TYPE (arg3_tree
),
5136 case FFEINTRIN_impFSTAT_subr
:
5142 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5143 ffecom_expr (arg1
));
5144 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5145 build_pointer_type (TREE_TYPE (arg1_tree
)),
5148 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5149 ffecom_ptr_to_expr (arg2
));
5152 arg3_tree
= NULL_TREE
;
5154 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5156 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5157 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5158 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5159 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5160 ffecom_gfrt_kindtype (gfrt
),
5164 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5165 ffebld_nonter_hook (expr
));
5166 if (arg3_tree
!= NULL_TREE
) {
5167 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5168 convert (TREE_TYPE (arg3_tree
),
5174 case FFEINTRIN_impKILL_subr
:
5180 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5181 ffecom_expr (arg1
));
5182 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5183 build_pointer_type (TREE_TYPE (arg1_tree
)),
5186 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5187 ffecom_expr (arg2
));
5188 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5189 build_pointer_type (TREE_TYPE (arg2_tree
)),
5193 arg3_tree
= NULL_TREE
;
5195 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5197 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5198 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5199 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5200 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5201 ffecom_gfrt_kindtype (gfrt
),
5205 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5206 ffebld_nonter_hook (expr
));
5207 if (arg3_tree
!= NULL_TREE
) {
5208 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5209 convert (TREE_TYPE (arg3_tree
),
5215 case FFEINTRIN_impCTIME_subr
:
5216 case FFEINTRIN_impTTYNAM_subr
:
5218 tree arg1_len
= integer_zero_node
;
5222 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5224 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5225 ffecom_f2c_longint_type_node
:
5226 ffecom_f2c_integer_type_node
),
5227 ffecom_expr (arg1
));
5228 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5229 build_pointer_type (TREE_TYPE (arg2_tree
)),
5232 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5233 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5234 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5235 TREE_CHAIN (arg1_len
) = arg2_tree
;
5236 TREE_CHAIN (arg1_tree
) = arg1_len
;
5239 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5240 ffecom_gfrt_kindtype (gfrt
),
5244 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5245 ffebld_nonter_hook (expr
));
5246 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5250 case FFEINTRIN_impIRAND
:
5251 case FFEINTRIN_impRAND
:
5252 /* Arg defaults to 0 (normal random case) */
5257 arg1_tree
= ffecom_integer_zero_node
;
5259 arg1_tree
= ffecom_expr (arg1
);
5260 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5262 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5263 build_pointer_type (TREE_TYPE (arg1_tree
)),
5265 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5267 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5268 ffecom_gfrt_kindtype (gfrt
),
5270 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5271 ffecom_f2c_integer_type_node
:
5272 ffecom_f2c_real_type_node
),
5274 dest_tree
, dest
, dest_used
,
5276 ffebld_nonter_hook (expr
));
5280 case FFEINTRIN_impFTELL_subr
:
5281 case FFEINTRIN_impUMASK_subr
:
5286 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5287 ffecom_expr (arg1
));
5288 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5289 build_pointer_type (TREE_TYPE (arg1_tree
)),
5293 arg2_tree
= NULL_TREE
;
5295 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5297 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5298 ffecom_gfrt_kindtype (gfrt
),
5301 build_tree_list (NULL_TREE
, arg1_tree
),
5302 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5304 ffebld_nonter_hook (expr
));
5305 if (arg2_tree
!= NULL_TREE
) {
5306 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5307 convert (TREE_TYPE (arg2_tree
),
5313 case FFEINTRIN_impCPU_TIME
:
5314 case FFEINTRIN_impSECOND_subr
:
5318 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5321 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5322 ffecom_gfrt_kindtype (gfrt
),
5326 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5327 ffebld_nonter_hook (expr
));
5330 = ffecom_modify (NULL_TREE
, arg1_tree
,
5331 convert (TREE_TYPE (arg1_tree
),
5336 case FFEINTRIN_impDTIME_subr
:
5337 case FFEINTRIN_impETIME_subr
:
5342 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5344 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5346 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5347 ffecom_gfrt_kindtype (gfrt
),
5350 build_tree_list (NULL_TREE
, arg1_tree
),
5351 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5353 ffebld_nonter_hook (expr
));
5354 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5355 convert (TREE_TYPE (result_tree
),
5360 /* Straightforward calls of libf2c routines: */
5361 case FFEINTRIN_impABORT
:
5362 case FFEINTRIN_impACCESS
:
5363 case FFEINTRIN_impBESJ0
:
5364 case FFEINTRIN_impBESJ1
:
5365 case FFEINTRIN_impBESJN
:
5366 case FFEINTRIN_impBESY0
:
5367 case FFEINTRIN_impBESY1
:
5368 case FFEINTRIN_impBESYN
:
5369 case FFEINTRIN_impCHDIR_func
:
5370 case FFEINTRIN_impCHMOD_func
:
5371 case FFEINTRIN_impDATE
:
5372 case FFEINTRIN_impDATE_AND_TIME
:
5373 case FFEINTRIN_impDBESJ0
:
5374 case FFEINTRIN_impDBESJ1
:
5375 case FFEINTRIN_impDBESJN
:
5376 case FFEINTRIN_impDBESY0
:
5377 case FFEINTRIN_impDBESY1
:
5378 case FFEINTRIN_impDBESYN
:
5379 case FFEINTRIN_impDTIME_func
:
5380 case FFEINTRIN_impETIME_func
:
5381 case FFEINTRIN_impFGETC_func
:
5382 case FFEINTRIN_impFGET_func
:
5383 case FFEINTRIN_impFNUM
:
5384 case FFEINTRIN_impFPUTC_func
:
5385 case FFEINTRIN_impFPUT_func
:
5386 case FFEINTRIN_impFSEEK
:
5387 case FFEINTRIN_impFSTAT_func
:
5388 case FFEINTRIN_impFTELL_func
:
5389 case FFEINTRIN_impGERROR
:
5390 case FFEINTRIN_impGETARG
:
5391 case FFEINTRIN_impGETCWD_func
:
5392 case FFEINTRIN_impGETENV
:
5393 case FFEINTRIN_impGETGID
:
5394 case FFEINTRIN_impGETLOG
:
5395 case FFEINTRIN_impGETPID
:
5396 case FFEINTRIN_impGETUID
:
5397 case FFEINTRIN_impGMTIME
:
5398 case FFEINTRIN_impHOSTNM_func
:
5399 case FFEINTRIN_impIDATE_unix
:
5400 case FFEINTRIN_impIDATE_vxt
:
5401 case FFEINTRIN_impIERRNO
:
5402 case FFEINTRIN_impISATTY
:
5403 case FFEINTRIN_impITIME
:
5404 case FFEINTRIN_impKILL_func
:
5405 case FFEINTRIN_impLINK_func
:
5406 case FFEINTRIN_impLNBLNK
:
5407 case FFEINTRIN_impLSTAT_func
:
5408 case FFEINTRIN_impLTIME
:
5409 case FFEINTRIN_impMCLOCK8
:
5410 case FFEINTRIN_impMCLOCK
:
5411 case FFEINTRIN_impPERROR
:
5412 case FFEINTRIN_impRENAME_func
:
5413 case FFEINTRIN_impSECNDS
:
5414 case FFEINTRIN_impSECOND_func
:
5415 case FFEINTRIN_impSLEEP
:
5416 case FFEINTRIN_impSRAND
:
5417 case FFEINTRIN_impSTAT_func
:
5418 case FFEINTRIN_impSYMLNK_func
:
5419 case FFEINTRIN_impSYSTEM_CLOCK
:
5420 case FFEINTRIN_impSYSTEM_func
:
5421 case FFEINTRIN_impTIME8
:
5422 case FFEINTRIN_impTIME_unix
:
5423 case FFEINTRIN_impTIME_vxt
:
5424 case FFEINTRIN_impUMASK_func
:
5425 case FFEINTRIN_impUNLINK_func
:
5428 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5429 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5430 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5431 case FFEINTRIN_impNONE
:
5432 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5433 fprintf (stderr
, "No %s implementation.\n",
5434 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5435 assert ("unimplemented intrinsic" == NULL
);
5436 return error_mark_node
;
5439 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5441 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5442 ffebld_right (expr
));
5444 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5445 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5447 expr_tree
, dest_tree
, dest
, dest_used
,
5449 ffebld_nonter_hook (expr
));
5451 /* See bottom of this file for f2c transforms used to determine
5452 many of the above implementations. The info seems to confuse
5453 Emacs's C mode indentation, which is why it's been moved to
5454 the bottom of this source file. */
5458 /* For power (exponentiation) where right-hand operand is type INTEGER,
5459 generate in-line code to do it the fast way (which, if the operand
5460 is a constant, might just mean a series of multiplies). */
5462 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5464 ffecom_expr_power_integer_ (ffebld expr
)
5466 tree l
= ffecom_expr (ffebld_left (expr
));
5467 tree r
= ffecom_expr (ffebld_right (expr
));
5468 tree ltype
= TREE_TYPE (l
);
5469 tree rtype
= TREE_TYPE (r
);
5470 tree result
= NULL_TREE
;
5472 if (l
== error_mark_node
5473 || r
== error_mark_node
)
5474 return error_mark_node
;
5476 if (TREE_CODE (r
) == INTEGER_CST
)
5478 int sgn
= tree_int_cst_sgn (r
);
5481 return convert (ltype
, integer_one_node
);
5483 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5486 /* Reciprocal of integer is either 0, -1, or 1, so after
5487 calculating that (which we leave to the back end to do
5488 or not do optimally), don't bother with any multiplying. */
5490 result
= ffecom_tree_divide_ (ltype
,
5491 convert (ltype
, integer_one_node
),
5493 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5494 r
= ffecom_1 (NEGATE_EXPR
,
5497 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5498 result
= ffecom_1 (ABS_EXPR
, rtype
,
5502 /* Generate appropriate series of multiplies, preceded
5503 by divide if the exponent is negative. */
5509 l
= ffecom_tree_divide_ (ltype
,
5510 convert (ltype
, integer_one_node
),
5512 NULL_TREE
, NULL
, NULL
,
5513 ffebld_nonter_hook (expr
));
5514 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5515 assert (TREE_CODE (r
) == INTEGER_CST
);
5517 if (tree_int_cst_sgn (r
) < 0)
5518 { /* The "most negative" number. */
5519 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5520 ffecom_2 (RSHIFT_EXPR
, rtype
,
5524 l
= ffecom_2 (MULT_EXPR
, ltype
,
5532 if (TREE_INT_CST_LOW (r
) & 1)
5534 if (result
== NULL_TREE
)
5537 result
= ffecom_2 (MULT_EXPR
, ltype
,
5542 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5545 if (integer_zerop (r
))
5547 assert (TREE_CODE (r
) == INTEGER_CST
);
5550 l
= ffecom_2 (MULT_EXPR
, ltype
,
5557 /* Though rhs isn't a constant, in-line code cannot be expanded
5558 while transforming dummies
5559 because the back end cannot be easily convinced to generate
5560 stores (MODIFY_EXPR), handle temporaries, and so on before
5561 all the appropriate rtx's have been generated for things like
5562 dummy args referenced in rhs -- which doesn't happen until
5563 store_parm_decls() is called (expand_function_start, I believe,
5564 does the actual rtx-stuffing of PARM_DECLs).
5566 So, in this case, let the caller generate the call to the
5567 run-time-library function to evaluate the power for us. */
5569 if (ffecom_transform_only_dummies_
)
5572 /* Right-hand operand not a constant, expand in-line code to figure
5573 out how to do the multiplies, &c.
5575 The returned expression is expressed this way in GNU C, where l and
5578 ({ typeof (r) rtmp = r;
5579 typeof (l) ltmp = l;
5586 if ((basetypeof (l) == basetypeof (int))
5589 result = ((typeof (l)) 1) / ltmp;
5590 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5596 if ((basetypeof (l) != basetypeof (int))
5599 ltmp = ((typeof (l)) 1) / ltmp;
5603 rtmp = -(rtmp >> 1);
5611 if ((rtmp >>= 1) == 0)
5620 Note that some of the above is compile-time collapsable, such as
5621 the first part of the if statements that checks the base type of
5622 l against int. The if statements are phrased that way to suggest
5623 an easy way to generate the if/else constructs here, knowing that
5624 the back end should (and probably does) eliminate the resulting
5625 dead code (either the int case or the non-int case), something
5626 it couldn't do without the redundant phrasing, requiring explicit
5627 dead-code elimination here, which would be kind of difficult to
5634 tree basetypeof_l_is_int
;
5639 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5641 se
= expand_start_stmt_expr ();
5643 ffecom_start_compstmt ();
5646 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5647 FFETARGET_charactersizeNONE
, -1);
5648 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5649 FFETARGET_charactersizeNONE
, -1);
5650 result
= ffecom_make_tempvar ("power_res", ltype
,
5651 FFETARGET_charactersizeNONE
, -1);
5652 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5653 || TREE_CODE (ltype
) == RECORD_TYPE
)
5654 divide
= ffecom_make_tempvar ("power_div", ltype
,
5655 FFETARGET_charactersizeNONE
, -1);
5662 hook
= ffebld_nonter_hook (expr
);
5664 assert (TREE_CODE (hook
) == TREE_VEC
);
5665 assert (TREE_VEC_LENGTH (hook
) == 4);
5666 rtmp
= TREE_VEC_ELT (hook
, 0);
5667 ltmp
= TREE_VEC_ELT (hook
, 1);
5668 result
= TREE_VEC_ELT (hook
, 2);
5669 divide
= TREE_VEC_ELT (hook
, 3);
5670 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5671 || TREE_CODE (ltype
) == RECORD_TYPE
)
5678 expand_expr_stmt (ffecom_modify (void_type_node
,
5681 expand_expr_stmt (ffecom_modify (void_type_node
,
5684 expand_start_cond (ffecom_truth_value
5685 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5687 convert (rtype
, integer_zero_node
))),
5689 expand_expr_stmt (ffecom_modify (void_type_node
,
5691 convert (ltype
, integer_one_node
)));
5692 expand_start_else ();
5693 if (! integer_zerop (basetypeof_l_is_int
))
5695 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5698 integer_zero_node
)),
5700 expand_expr_stmt (ffecom_modify (void_type_node
,
5704 convert (ltype
, integer_one_node
),
5706 NULL_TREE
, NULL
, NULL
,
5708 expand_start_cond (ffecom_truth_value
5709 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5710 ffecom_2 (LT_EXPR
, integer_type_node
,
5713 integer_zero_node
)),
5714 ffecom_2 (EQ_EXPR
, integer_type_node
,
5715 ffecom_2 (BIT_AND_EXPR
,
5717 ffecom_1 (NEGATE_EXPR
,
5723 integer_zero_node
)))),
5725 expand_expr_stmt (ffecom_modify (void_type_node
,
5727 ffecom_1 (NEGATE_EXPR
,
5731 expand_start_else ();
5733 expand_expr_stmt (ffecom_modify (void_type_node
,
5735 convert (ltype
, integer_one_node
)));
5736 expand_start_cond (ffecom_truth_value
5737 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5738 ffecom_truth_value_invert
5739 (basetypeof_l_is_int
),
5740 ffecom_2 (LT_EXPR
, integer_type_node
,
5743 integer_zero_node
)))),
5745 expand_expr_stmt (ffecom_modify (void_type_node
,
5749 convert (ltype
, integer_one_node
),
5751 NULL_TREE
, NULL
, NULL
,
5753 expand_expr_stmt (ffecom_modify (void_type_node
,
5755 ffecom_1 (NEGATE_EXPR
, rtype
,
5757 expand_start_cond (ffecom_truth_value
5758 (ffecom_2 (LT_EXPR
, integer_type_node
,
5760 convert (rtype
, integer_zero_node
))),
5762 expand_expr_stmt (ffecom_modify (void_type_node
,
5764 ffecom_1 (NEGATE_EXPR
, rtype
,
5765 ffecom_2 (RSHIFT_EXPR
,
5768 integer_one_node
))));
5769 expand_expr_stmt (ffecom_modify (void_type_node
,
5771 ffecom_2 (MULT_EXPR
, ltype
,
5776 expand_start_loop (1);
5777 expand_start_cond (ffecom_truth_value
5778 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5780 convert (rtype
, integer_one_node
))),
5782 expand_expr_stmt (ffecom_modify (void_type_node
,
5784 ffecom_2 (MULT_EXPR
, ltype
,
5788 expand_exit_loop_if_false (NULL
,
5790 (ffecom_modify (rtype
,
5792 ffecom_2 (RSHIFT_EXPR
,
5795 integer_one_node
))));
5796 expand_expr_stmt (ffecom_modify (void_type_node
,
5798 ffecom_2 (MULT_EXPR
, ltype
,
5803 if (!integer_zerop (basetypeof_l_is_int
))
5805 expand_expr_stmt (result
);
5807 t
= ffecom_end_compstmt ();
5809 result
= expand_end_stmt_expr (se
);
5811 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5813 if (TREE_CODE (t
) == BLOCK
)
5815 /* Make a BIND_EXPR for the BLOCK already made. */
5816 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5817 NULL_TREE
, result
, t
);
5818 /* Remove the block from the tree at this point.
5819 It gets put back at the proper place
5820 when the BIND_EXPR is expanded. */
5831 /* ffecom_expr_transform_ -- Transform symbols in expr
5833 ffebld expr; // FFE expression.
5834 ffecom_expr_transform_ (expr);
5836 Recursive descent on expr while transforming any untransformed SYMTERs. */
5838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5840 ffecom_expr_transform_ (ffebld expr
)
5845 tail_recurse
: /* :::::::::::::::::::: */
5850 switch (ffebld_op (expr
))
5852 case FFEBLD_opSYMTER
:
5853 s
= ffebld_symter (expr
);
5854 t
= ffesymbol_hook (s
).decl_tree
;
5855 if ((t
== NULL_TREE
)
5856 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5857 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5858 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5860 s
= ffecom_sym_transform_ (s
);
5861 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5864 break; /* Ok if (t == NULL) here. */
5867 ffecom_expr_transform_ (ffebld_head (expr
));
5868 expr
= ffebld_trail (expr
);
5869 goto tail_recurse
; /* :::::::::::::::::::: */
5875 switch (ffebld_arity (expr
))
5878 ffecom_expr_transform_ (ffebld_left (expr
));
5879 expr
= ffebld_right (expr
);
5880 goto tail_recurse
; /* :::::::::::::::::::: */
5883 expr
= ffebld_left (expr
);
5884 goto tail_recurse
; /* :::::::::::::::::::: */
5894 /* Make a type based on info in live f2c.h file. */
5896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5898 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5902 case FFECOM_f2ccodeCHAR
:
5903 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5906 case FFECOM_f2ccodeSHORT
:
5907 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5910 case FFECOM_f2ccodeINT
:
5911 *type
= make_signed_type (INT_TYPE_SIZE
);
5914 case FFECOM_f2ccodeLONG
:
5915 *type
= make_signed_type (LONG_TYPE_SIZE
);
5918 case FFECOM_f2ccodeLONGLONG
:
5919 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5922 case FFECOM_f2ccodeCHARPTR
:
5923 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5924 ? signed_char_type_node
5925 : unsigned_char_type_node
);
5928 case FFECOM_f2ccodeFLOAT
:
5929 *type
= make_node (REAL_TYPE
);
5930 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5931 layout_type (*type
);
5934 case FFECOM_f2ccodeDOUBLE
:
5935 *type
= make_node (REAL_TYPE
);
5936 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5937 layout_type (*type
);
5940 case FFECOM_f2ccodeLONGDOUBLE
:
5941 *type
= make_node (REAL_TYPE
);
5942 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5943 layout_type (*type
);
5946 case FFECOM_f2ccodeTWOREALS
:
5947 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5950 case FFECOM_f2ccodeTWODOUBLEREALS
:
5951 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5955 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5956 *type
= error_mark_node
;
5960 pushdecl (build_decl (TYPE_DECL
,
5961 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5967 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5971 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
5977 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
5978 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
5979 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
5981 assert (code
!= -1);
5982 ffecom_f2c_typecode_
[bt
][j
] = code
;
5988 /* Finish up globals after doing all program units in file
5990 Need to handle only uninitialized COMMON areas. */
5992 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5994 ffecom_finish_global_ (ffeglobal global
)
6000 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6003 if (ffeglobal_common_init (global
))
6006 cbt
= ffeglobal_hook (global
);
6007 if ((cbt
== NULL_TREE
)
6008 || !ffeglobal_common_have_size (global
))
6009 return global
; /* No need to make common, never ref'd. */
6011 DECL_EXTERNAL (cbt
) = 0;
6013 /* Give the array a size now. */
6015 size
= build_int_2 ((ffeglobal_common_size (global
)
6016 + ffeglobal_common_pad (global
)) - 1,
6019 cbtype
= TREE_TYPE (cbt
);
6020 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6023 if (!TREE_TYPE (size
))
6024 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6025 layout_type (cbtype
);
6027 cbt
= start_decl (cbt
, FALSE
);
6028 assert (cbt
== ffeglobal_hook (global
));
6030 finish_decl (cbt
, NULL_TREE
, FALSE
);
6036 /* Finish up any untransformed symbols. */
6038 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6040 ffecom_finish_symbol_transform_ (ffesymbol s
)
6042 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6045 /* It's easy to know to transform an untransformed symbol, to make sure
6046 we put out debugging info for it. But COMMON variables, unlike
6047 EQUIVALENCE ones, aren't given declarations in addition to the
6048 tree expressions that specify offsets, because COMMON variables
6049 can be referenced in the outer scope where only dummy arguments
6050 (PARM_DECLs) should really be seen. To be safe, just don't do any
6051 VAR_DECLs for COMMON variables when we transform them for real
6052 use, and therefore we do all the VAR_DECL creating here. */
6054 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6056 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
6057 || (ffesymbol_where (s
) != FFEINFO_whereNONE
6058 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
6059 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6060 /* Not transformed, and not CHARACTER*(*), and not a dummy
6061 argument, which can happen only if the entry point names
6062 it "rides in on" are all invalidated for other reasons. */
6063 s
= ffecom_sym_transform_ (s
);
6066 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6067 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6069 /* This isn't working, at least for dbxout. The .s file looks
6070 okay to me (burley), but in gdb 4.9 at least, the variables
6071 appear to reside somewhere outside of the common area, so
6072 it doesn't make sense to mislead anyone by generating the info
6073 on those variables until this is fixed. NOTE: Same problem
6074 with EQUIVALENCE, sadly...see similar #if later. */
6075 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6076 ffesymbol_storage (s
));
6083 /* Append underscore(s) to name before calling get_identifier. "us"
6084 is nonzero if the name already contains an underscore and thus
6085 needs two underscores appended. */
6087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6089 ffecom_get_appended_identifier_ (char us
, const char *name
)
6095 newname
= xmalloc ((i
= strlen (name
)) + 1
6096 + ffe_is_underscoring ()
6098 memcpy (newname
, name
, i
);
6100 newname
[i
+ us
] = '_';
6101 newname
[i
+ 1 + us
] = '\0';
6102 id
= get_identifier (newname
);
6110 /* Decide whether to append underscore to name before calling
6113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6115 ffecom_get_external_identifier_ (ffesymbol s
)
6118 const char *name
= ffesymbol_text (s
);
6120 /* If name is a built-in name, just return it as is. */
6122 if (!ffe_is_underscoring ()
6123 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6124 #if FFETARGET_isENFORCED_MAIN_NAME
6125 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6127 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6129 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6130 return get_identifier (name
);
6132 us
= ffe_is_second_underscore ()
6133 ? (strchr (name
, '_') != NULL
)
6136 return ffecom_get_appended_identifier_ (us
, name
);
6140 /* Decide whether to append underscore to internal name before calling
6143 This is for non-external, top-function-context names only. Transform
6144 identifier so it doesn't conflict with the transformed result
6145 of using a _different_ external name. E.g. if "CALL FOO" is
6146 transformed into "FOO_();", then the variable in "FOO_ = 3"
6147 must be transformed into something that does not conflict, since
6148 these two things should be independent.
6150 The transformation is as follows. If the name does not contain
6151 an underscore, there is no possible conflict, so just return.
6152 If the name does contain an underscore, then transform it just
6153 like we transform an external identifier. */
6155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6157 ffecom_get_identifier_ (const char *name
)
6159 /* If name does not contain an underscore, just return it as is. */
6161 if (!ffe_is_underscoring ()
6162 || (strchr (name
, '_') == NULL
))
6163 return get_identifier (name
);
6165 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6170 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6173 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6174 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6175 ffesymbol_kindtype(s));
6177 Call after setting up containing function and getting trees for all
6180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6182 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6184 ffebld expr
= ffesymbol_sfexpr (s
);
6188 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6189 static bool recurse
= FALSE
;
6190 int old_lineno
= lineno
;
6191 const char *old_input_filename
= input_filename
;
6193 ffecom_nested_entry_
= s
;
6195 /* For now, we don't have a handy pointer to where the sfunc is actually
6196 defined, though that should be easy to add to an ffesymbol. (The
6197 token/where info available might well point to the place where the type
6198 of the sfunc is declared, especially if that precedes the place where
6199 the sfunc itself is defined, which is typically the case.) We should
6200 put out a null pointer rather than point somewhere wrong, but I want to
6201 see how it works at this point. */
6203 input_filename
= ffesymbol_where_filename (s
);
6204 lineno
= ffesymbol_where_filelinenum (s
);
6206 /* Pretransform the expression so any newly discovered things belong to the
6207 outer program unit, not to the statement function. */
6209 ffecom_expr_transform_ (expr
);
6211 /* Make sure no recursive invocation of this fn (a specific case of failing
6212 to pretransform an sfunc's expression, i.e. where its expression
6213 references another untransformed sfunc) happens. */
6218 push_f_function_context ();
6221 type
= void_type_node
;
6224 type
= ffecom_tree_type
[bt
][kt
];
6225 if (type
== NULL_TREE
)
6226 type
= integer_type_node
; /* _sym_exec_transition reports
6230 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6231 build_function_type (type
, NULL_TREE
),
6232 1, /* nested/inline */
6233 0); /* TREE_PUBLIC */
6235 /* We don't worry about COMPLEX return values here, because this is
6236 entirely internal to our code, and gcc has the ability to return COMPLEX
6237 directly as a value. */
6240 { /* Prepend arg for where result goes. */
6243 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6245 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6247 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6249 type
= build_pointer_type (type
);
6250 result
= build_decl (PARM_DECL
, result
, type
);
6252 push_parm_decl (result
);
6255 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6257 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6259 store_parm_decls (0);
6261 ffecom_start_compstmt ();
6267 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6270 result_length
= build_int_2 (sz
, 0);
6271 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6273 ffecom_prepare_let_char_ (sz
, expr
);
6275 ffecom_prepare_end ();
6277 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6278 expand_null_return ();
6282 ffecom_prepare_expr (expr
);
6284 ffecom_prepare_end ();
6286 expand_return (ffecom_modify (NULL_TREE
,
6287 DECL_RESULT (current_function_decl
),
6288 ffecom_expr (expr
)));
6292 ffecom_end_compstmt ();
6294 func
= current_function_decl
;
6295 finish_function (1);
6297 pop_f_function_context ();
6301 lineno
= old_lineno
;
6302 input_filename
= old_input_filename
;
6304 ffecom_nested_entry_
= NULL
;
6311 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6313 ffecom_gfrt_args_ (ffecomGfrt ix
)
6315 return ffecom_gfrt_argstring_
[ix
];
6319 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6321 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6323 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6324 ffecom_make_gfrt_ (ix
);
6326 return ffecom_1 (ADDR_EXPR
,
6327 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6332 /* Return initialize-to-zero expression for this VAR_DECL. */
6334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6335 /* A somewhat evil way to prevent the garbage collector
6336 from collecting 'tree' structures. */
6337 #define NUM_TRACKED_CHUNK 63
6338 static struct tree_ggc_tracker
6340 struct tree_ggc_tracker
*next
;
6341 tree trees
[NUM_TRACKED_CHUNK
];
6342 } *tracker_head
= NULL
;
6345 mark_tracker_head (void *arg
)
6347 struct tree_ggc_tracker
*head
;
6350 for (head
= * (struct tree_ggc_tracker
**) arg
;
6355 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6356 ggc_mark_tree (head
->trees
[i
]);
6361 ffecom_save_tree_forever (tree t
)
6364 if (tracker_head
!= NULL
)
6365 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6366 if (tracker_head
->trees
[i
] == NULL
)
6368 tracker_head
->trees
[i
] = t
;
6373 /* Need to allocate a new block. */
6374 struct tree_ggc_tracker
*old_head
= tracker_head
;
6376 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6377 tracker_head
->next
= old_head
;
6378 tracker_head
->trees
[0] = t
;
6379 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6380 tracker_head
->trees
[i
] = NULL
;
6385 ffecom_init_zero_ (tree decl
)
6388 int incremental
= TREE_STATIC (decl
);
6389 tree type
= TREE_TYPE (decl
);
6393 make_decl_rtl (decl
, NULL
);
6394 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6397 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6398 && (TREE_CODE (type
) != RECORD_TYPE
)
6399 && (TREE_CODE (type
) != UNION_TYPE
)
6401 init
= convert (type
, integer_zero_node
);
6402 else if (!incremental
)
6404 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6405 TREE_CONSTANT (init
) = 1;
6406 TREE_STATIC (init
) = 1;
6410 assemble_zeros (int_size_in_bytes (type
));
6411 init
= error_mark_node
;
6418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6420 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6426 switch (ffebld_op (arg
))
6428 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6429 if (ffetarget_length_character1
6430 (ffebld_constant_character1
6431 (ffebld_conter (arg
))) == 0)
6433 *maybe_tree
= integer_zero_node
;
6434 return convert (tree_type
, integer_zero_node
);
6437 *maybe_tree
= integer_one_node
;
6438 expr_tree
= build_int_2 (*ffetarget_text_character1
6439 (ffebld_constant_character1
6440 (ffebld_conter (arg
))),
6442 TREE_TYPE (expr_tree
) = tree_type
;
6445 case FFEBLD_opSYMTER
:
6446 case FFEBLD_opARRAYREF
:
6447 case FFEBLD_opFUNCREF
:
6448 case FFEBLD_opSUBSTR
:
6449 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6451 if ((expr_tree
== error_mark_node
)
6452 || (length_tree
== error_mark_node
))
6454 *maybe_tree
= error_mark_node
;
6455 return error_mark_node
;
6458 if (integer_zerop (length_tree
))
6460 *maybe_tree
= integer_zero_node
;
6461 return convert (tree_type
, integer_zero_node
);
6465 = ffecom_1 (INDIRECT_REF
,
6466 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6469 = ffecom_2 (ARRAY_REF
,
6470 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6473 expr_tree
= convert (tree_type
, expr_tree
);
6475 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6476 *maybe_tree
= integer_one_node
;
6477 else /* Must check length at run time. */
6479 = ffecom_truth_value
6480 (ffecom_2 (GT_EXPR
, integer_type_node
,
6482 ffecom_f2c_ftnlen_zero_node
));
6485 case FFEBLD_opPAREN
:
6486 case FFEBLD_opCONVERT
:
6487 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6489 *maybe_tree
= integer_zero_node
;
6490 return convert (tree_type
, integer_zero_node
);
6492 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6495 case FFEBLD_opCONCATENATE
:
6502 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6504 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6506 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6509 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6517 assert ("bad op in ICHAR" == NULL
);
6518 return error_mark_node
;
6523 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6527 length_arg = ffecom_intrinsic_len_ (expr);
6529 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6530 subexpressions by constructing the appropriate tree for the
6531 length-of-character-text argument in a calling sequence. */
6533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6535 ffecom_intrinsic_len_ (ffebld expr
)
6537 ffetargetCharacter1 val
;
6540 switch (ffebld_op (expr
))
6542 case FFEBLD_opCONTER
:
6543 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6544 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6545 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6548 case FFEBLD_opSYMTER
:
6550 ffesymbol s
= ffebld_symter (expr
);
6553 item
= ffesymbol_hook (s
).decl_tree
;
6554 if (item
== NULL_TREE
)
6556 s
= ffecom_sym_transform_ (s
);
6557 item
= ffesymbol_hook (s
).decl_tree
;
6559 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6561 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6562 length
= ffesymbol_hook (s
).length_tree
;
6565 length
= build_int_2 (ffesymbol_size (s
), 0);
6566 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6569 else if (item
== error_mark_node
)
6570 length
= error_mark_node
;
6571 else /* FFEINFO_kindFUNCTION: */
6576 case FFEBLD_opARRAYREF
:
6577 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6580 case FFEBLD_opSUBSTR
:
6584 ffebld thing
= ffebld_right (expr
);
6588 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6589 start
= ffebld_head (thing
);
6590 thing
= ffebld_trail (thing
);
6591 assert (ffebld_trail (thing
) == NULL
);
6592 end
= ffebld_head (thing
);
6594 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6596 if (length
== error_mark_node
)
6605 length
= convert (ffecom_f2c_ftnlen_type_node
,
6611 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6612 ffecom_expr (start
));
6614 if (start_tree
== error_mark_node
)
6616 length
= error_mark_node
;
6622 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6623 ffecom_f2c_ftnlen_one_node
,
6624 ffecom_2 (MINUS_EXPR
,
6625 ffecom_f2c_ftnlen_type_node
,
6631 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6634 if (end_tree
== error_mark_node
)
6636 length
= error_mark_node
;
6640 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6641 ffecom_f2c_ftnlen_one_node
,
6642 ffecom_2 (MINUS_EXPR
,
6643 ffecom_f2c_ftnlen_type_node
,
6644 end_tree
, start_tree
));
6650 case FFEBLD_opCONCATENATE
:
6652 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6653 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6654 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6657 case FFEBLD_opFUNCREF
:
6658 case FFEBLD_opCONVERT
:
6659 length
= build_int_2 (ffebld_size (expr
), 0);
6660 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6664 assert ("bad op for single char arg expr" == NULL
);
6665 length
= ffecom_f2c_ftnlen_zero_node
;
6669 assert (length
!= NULL_TREE
);
6675 /* Handle CHARACTER assignments.
6677 Generates code to do the assignment. Used by ordinary assignment
6678 statement handler ffecom_let_stmt and by statement-function
6679 handler to generate code for a statement function. */
6681 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6683 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6684 ffetargetCharacterSize dest_size
, ffebld source
)
6686 ffecomConcatList_ catlist
;
6691 if ((dest_tree
== error_mark_node
)
6692 || (dest_length
== error_mark_node
))
6695 assert (dest_tree
!= NULL_TREE
);
6696 assert (dest_length
!= NULL_TREE
);
6698 /* Source might be an opCONVERT, which just means it is a different size
6699 than the destination. Since the underlying implementation here handles
6700 that (directly or via the s_copy or s_cat run-time-library functions),
6701 we don't need the "convenience" of an opCONVERT that tells us to
6702 truncate or blank-pad, particularly since the resulting implementation
6703 would probably be slower than otherwise. */
6705 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6706 source
= ffebld_left (source
);
6708 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6709 switch (ffecom_concat_list_count_ (catlist
))
6711 case 0: /* Shouldn't happen, but in case it does... */
6712 ffecom_concat_list_kill_ (catlist
);
6713 source_tree
= null_pointer_node
;
6714 source_length
= ffecom_f2c_ftnlen_zero_node
;
6715 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6716 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6717 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6718 = build_tree_list (NULL_TREE
, dest_length
);
6719 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6720 = build_tree_list (NULL_TREE
, source_length
);
6722 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6723 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6725 expand_expr_stmt (expr_tree
);
6729 case 1: /* The (fairly) easy case. */
6730 ffecom_char_args_ (&source_tree
, &source_length
,
6731 ffecom_concat_list_expr_ (catlist
, 0));
6732 ffecom_concat_list_kill_ (catlist
);
6733 assert (source_tree
!= NULL_TREE
);
6734 assert (source_length
!= NULL_TREE
);
6736 if ((source_tree
== error_mark_node
)
6737 || (source_length
== error_mark_node
))
6743 = ffecom_1 (INDIRECT_REF
,
6744 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6748 = ffecom_2 (ARRAY_REF
,
6749 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6754 = ffecom_1 (INDIRECT_REF
,
6755 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6759 = ffecom_2 (ARRAY_REF
,
6760 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6765 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6767 expand_expr_stmt (expr_tree
);
6772 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6773 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6774 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6775 = build_tree_list (NULL_TREE
, dest_length
);
6776 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6777 = build_tree_list (NULL_TREE
, source_length
);
6779 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6780 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6782 expand_expr_stmt (expr_tree
);
6786 default: /* Must actually concatenate things. */
6790 /* Heavy-duty concatenation. */
6793 int count
= ffecom_concat_list_count_ (catlist
);
6805 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
6806 FFETARGET_charactersizeNONE
, count
, TRUE
);
6807 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
6808 FFETARGET_charactersizeNONE
,
6814 hook
= ffebld_nonter_hook (source
);
6816 assert (TREE_CODE (hook
) == TREE_VEC
);
6817 assert (TREE_VEC_LENGTH (hook
) == 2);
6818 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6819 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6823 for (i
= 0; i
< count
; ++i
)
6825 ffecom_char_args_ (&citem
, &clength
,
6826 ffecom_concat_list_expr_ (catlist
, i
));
6827 if ((citem
== error_mark_node
)
6828 || (clength
== error_mark_node
))
6830 ffecom_concat_list_kill_ (catlist
);
6835 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6836 ffecom_modify (void_type_node
,
6837 ffecom_2 (ARRAY_REF
,
6838 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6840 build_int_2 (i
, 0)),
6844 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6845 ffecom_modify (void_type_node
,
6846 ffecom_2 (ARRAY_REF
,
6847 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6849 build_int_2 (i
, 0)),
6854 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6855 TREE_CHAIN (expr_tree
)
6856 = build_tree_list (NULL_TREE
,
6857 ffecom_1 (ADDR_EXPR
,
6858 build_pointer_type (TREE_TYPE (items
)),
6860 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6861 = build_tree_list (NULL_TREE
,
6862 ffecom_1 (ADDR_EXPR
,
6863 build_pointer_type (TREE_TYPE (lengths
)),
6865 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6868 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6869 convert (ffecom_f2c_ftnlen_type_node
,
6870 build_int_2 (count
, 0))));
6871 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6872 = build_tree_list (NULL_TREE
, dest_length
);
6874 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6875 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6877 expand_expr_stmt (expr_tree
);
6880 ffecom_concat_list_kill_ (catlist
);
6884 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6887 ffecom_make_gfrt_(ix);
6889 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6890 for the indicated run-time routine (ix). */
6892 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6894 ffecom_make_gfrt_ (ffecomGfrt ix
)
6899 switch (ffecom_gfrt_type_
[ix
])
6901 case FFECOM_rttypeVOID_
:
6902 ttype
= void_type_node
;
6905 case FFECOM_rttypeVOIDSTAR_
:
6906 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6909 case FFECOM_rttypeFTNINT_
:
6910 ttype
= ffecom_f2c_ftnint_type_node
;
6913 case FFECOM_rttypeINTEGER_
:
6914 ttype
= ffecom_f2c_integer_type_node
;
6917 case FFECOM_rttypeLONGINT_
:
6918 ttype
= ffecom_f2c_longint_type_node
;
6921 case FFECOM_rttypeLOGICAL_
:
6922 ttype
= ffecom_f2c_logical_type_node
;
6925 case FFECOM_rttypeREAL_F2C_
:
6926 ttype
= double_type_node
;
6929 case FFECOM_rttypeREAL_GNU_
:
6930 ttype
= float_type_node
;
6933 case FFECOM_rttypeCOMPLEX_F2C_
:
6934 ttype
= void_type_node
;
6937 case FFECOM_rttypeCOMPLEX_GNU_
:
6938 ttype
= ffecom_f2c_complex_type_node
;
6941 case FFECOM_rttypeDOUBLE_
:
6942 ttype
= double_type_node
;
6945 case FFECOM_rttypeDOUBLEREAL_
:
6946 ttype
= ffecom_f2c_doublereal_type_node
;
6949 case FFECOM_rttypeDBLCMPLX_F2C_
:
6950 ttype
= void_type_node
;
6953 case FFECOM_rttypeDBLCMPLX_GNU_
:
6954 ttype
= ffecom_f2c_doublecomplex_type_node
;
6957 case FFECOM_rttypeCHARACTER_
:
6958 ttype
= void_type_node
;
6963 assert ("bad rttype" == NULL
);
6967 ttype
= build_function_type (ttype
, NULL_TREE
);
6968 t
= build_decl (FUNCTION_DECL
,
6969 get_identifier (ffecom_gfrt_name_
[ix
]),
6971 DECL_EXTERNAL (t
) = 1;
6972 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6973 TREE_PUBLIC (t
) = 1;
6974 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6976 /* Sanity check: A function that's const cannot be volatile. */
6978 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
6980 /* Sanity check: A function that's const cannot return complex. */
6982 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
6984 t
= start_decl (t
, TRUE
);
6986 finish_decl (t
, NULL_TREE
, TRUE
);
6988 ffecom_gfrt_
[ix
] = t
;
6992 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6994 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6996 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
6998 ffesymbol s
= ffestorag_symbol (st
);
7000 if (ffesymbol_namelisted (s
))
7001 ffecom_member_namelisted_
= TRUE
;
7005 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7006 the member so debugger will see it. Otherwise nobody should be
7007 referencing the member. */
7009 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7011 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7019 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7020 || (mt
== error_mark_node
))
7024 || ((s
= ffestorag_symbol (st
)) == NULL
))
7027 type
= ffecom_type_localvar_ (s
,
7028 ffesymbol_basictype (s
),
7029 ffesymbol_kindtype (s
));
7030 if (type
== error_mark_node
)
7033 t
= build_decl (VAR_DECL
,
7034 ffecom_get_identifier_ (ffesymbol_text (s
)),
7037 TREE_STATIC (t
) = TREE_STATIC (mt
);
7038 DECL_INITIAL (t
) = NULL_TREE
;
7039 TREE_ASM_WRITTEN (t
) = 1;
7043 gen_rtx (MEM
, TYPE_MODE (type
),
7044 plus_constant (XEXP (DECL_RTL (mt
), 0),
7045 ffestorag_modulo (mst
)
7046 + ffestorag_offset (st
)
7047 - ffestorag_offset (mst
))));
7049 t
= start_decl (t
, FALSE
);
7051 finish_decl (t
, NULL_TREE
, FALSE
);
7055 /* Prepare source expression for assignment into a destination perhaps known
7056 to be of a specific size. */
7059 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
7061 ffecomConcatList_ catlist
;
7066 tree tempvar
= NULL_TREE
;
7068 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7069 source
= ffebld_left (source
);
7071 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7072 count
= ffecom_concat_list_count_ (catlist
);
7077 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
7078 FFETARGET_charactersizeNONE
, count
);
7080 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
7081 FFETARGET_charactersizeNONE
, count
);
7083 tempvar
= make_tree_vec (2);
7084 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
7085 TREE_VEC_ELT (tempvar
, 1) = itmp
;
7088 for (i
= 0; i
< count
; ++i
)
7089 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
7091 ffecom_concat_list_kill_ (catlist
);
7095 ffebld_nonter_set_hook (source
, tempvar
);
7096 current_binding_level
->prep_state
= 1;
7100 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7102 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7103 (which generates their trees) and then their trees get push_parm_decl'd.
7105 The second arg is TRUE if the dummies are for a statement function, in
7106 which case lengths are not pushed for character arguments (since they are
7107 always known by both the caller and the callee, though the code allows
7108 for someday permitting CHAR*(*) stmtfunc dummies). */
7110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7112 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7119 ffecom_transform_only_dummies_
= TRUE
;
7121 /* First push the parms corresponding to actual dummy "contents". */
7123 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7125 dummy
= ffebld_head (dumlist
);
7126 switch (ffebld_op (dummy
))
7130 continue; /* Forget alternate returns. */
7135 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7136 s
= ffebld_symter (dummy
);
7137 parm
= ffesymbol_hook (s
).decl_tree
;
7138 if (parm
== NULL_TREE
)
7140 s
= ffecom_sym_transform_ (s
);
7141 parm
= ffesymbol_hook (s
).decl_tree
;
7142 assert (parm
!= NULL_TREE
);
7144 if (parm
!= error_mark_node
)
7145 push_parm_decl (parm
);
7148 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7150 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7152 dummy
= ffebld_head (dumlist
);
7153 switch (ffebld_op (dummy
))
7157 continue; /* Forget alternate returns, they mean
7163 s
= ffebld_symter (dummy
);
7164 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7165 continue; /* Only looking for CHARACTER arguments. */
7166 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7167 continue; /* Stmtfunc arg with known size needs no
7169 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7170 continue; /* Only looking for variables and arrays. */
7171 parm
= ffesymbol_hook (s
).length_tree
;
7172 assert (parm
!= NULL_TREE
);
7173 if (parm
!= error_mark_node
)
7174 push_parm_decl (parm
);
7177 ffecom_transform_only_dummies_
= FALSE
;
7181 /* ffecom_start_progunit_ -- Beginning of program unit
7183 Does GNU back end stuff necessary to teach it about the start of its
7184 equivalent of a Fortran program unit. */
7186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7188 ffecom_start_progunit_ ()
7190 ffesymbol fn
= ffecom_primary_entry_
;
7192 tree id
; /* Identifier (name) of function. */
7193 tree type
; /* Type of function. */
7194 tree result
; /* Result of function. */
7195 ffeinfoBasictype bt
;
7199 ffeglobalType egt
= FFEGLOBAL_type
;
7202 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7205 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7206 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7207 bool main_program
= FALSE
;
7208 int old_lineno
= lineno
;
7209 const char *old_input_filename
= input_filename
;
7211 assert (fn
!= NULL
);
7212 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7214 input_filename
= ffesymbol_where_filename (fn
);
7215 lineno
= ffesymbol_where_filelinenum (fn
);
7217 switch (ffecom_primary_entry_kind_
)
7219 case FFEINFO_kindPROGRAM
:
7220 main_program
= TRUE
;
7221 gt
= FFEGLOBAL_typeMAIN
;
7222 bt
= FFEINFO_basictypeNONE
;
7223 kt
= FFEINFO_kindtypeNONE
;
7224 type
= ffecom_tree_fun_type_void
;
7229 case FFEINFO_kindBLOCKDATA
:
7230 gt
= FFEGLOBAL_typeBDATA
;
7231 bt
= FFEINFO_basictypeNONE
;
7232 kt
= FFEINFO_kindtypeNONE
;
7233 type
= ffecom_tree_fun_type_void
;
7238 case FFEINFO_kindFUNCTION
:
7239 gt
= FFEGLOBAL_typeFUNC
;
7240 egt
= FFEGLOBAL_typeEXT
;
7241 bt
= ffesymbol_basictype (fn
);
7242 kt
= ffesymbol_kindtype (fn
);
7243 if (bt
== FFEINFO_basictypeNONE
)
7245 ffeimplic_establish_symbol (fn
);
7246 if (ffesymbol_funcresult (fn
) != NULL
)
7247 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7248 bt
= ffesymbol_basictype (fn
);
7249 kt
= ffesymbol_kindtype (fn
);
7253 charfunc
= cmplxfunc
= FALSE
;
7254 else if (bt
== FFEINFO_basictypeCHARACTER
)
7255 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7256 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7257 && ffesymbol_is_f2c (fn
)
7259 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7261 charfunc
= cmplxfunc
= FALSE
;
7263 if (multi
|| charfunc
)
7264 type
= ffecom_tree_fun_type_void
;
7265 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7266 type
= ffecom_tree_fun_type
[bt
][kt
];
7268 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7270 if ((type
== NULL_TREE
)
7271 || (TREE_TYPE (type
) == NULL_TREE
))
7272 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7275 case FFEINFO_kindSUBROUTINE
:
7276 gt
= FFEGLOBAL_typeSUBR
;
7277 egt
= FFEGLOBAL_typeEXT
;
7278 bt
= FFEINFO_basictypeNONE
;
7279 kt
= FFEINFO_kindtypeNONE
;
7280 if (ffecom_is_altreturning_
)
7281 type
= ffecom_tree_subr_type
;
7283 type
= ffecom_tree_fun_type_void
;
7289 assert ("say what??" == NULL
);
7291 case FFEINFO_kindANY
:
7292 gt
= FFEGLOBAL_typeANY
;
7293 bt
= FFEINFO_basictypeNONE
;
7294 kt
= FFEINFO_kindtypeNONE
;
7295 type
= error_mark_node
;
7303 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7304 ffesymbol_text (fn
));
7306 #if FFETARGET_isENFORCED_MAIN
7307 else if (main_program
)
7308 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7311 id
= ffecom_get_external_identifier_ (fn
);
7315 0, /* nested/inline */
7316 !altentries
); /* TREE_PUBLIC */
7318 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7321 && ((g
= ffesymbol_global (fn
)) != NULL
)
7322 && ((ffeglobal_type (g
) == gt
)
7323 || (ffeglobal_type (g
) == egt
)))
7325 ffeglobal_set_hook (g
, current_function_decl
);
7328 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7329 exec-transitioning needs current_function_decl to be filled in. So we
7330 do these things in two phases. */
7333 { /* 1st arg identifies which entrypoint. */
7334 ffecom_which_entrypoint_decl_
7335 = build_decl (PARM_DECL
,
7336 ffecom_get_invented_identifier ("__g77_%s",
7337 "which_entrypoint"),
7339 push_parm_decl (ffecom_which_entrypoint_decl_
);
7345 { /* Arg for result (return value). */
7350 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7352 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7354 type
= ffecom_multi_type_node_
;
7356 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7358 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7361 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7363 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7365 type
= build_pointer_type (type
);
7366 result
= build_decl (PARM_DECL
, result
, type
);
7368 push_parm_decl (result
);
7370 ffecom_multi_retval_
= result
;
7372 ffecom_func_result_
= result
;
7376 push_parm_decl (length
);
7377 ffecom_func_length_
= length
;
7381 if (ffecom_primary_entry_is_proc_
)
7384 arglist
= ffecom_master_arglist_
;
7386 arglist
= ffesymbol_dummyargs (fn
);
7387 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7390 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7391 store_parm_decls (main_program
? 1 : 0);
7393 ffecom_start_compstmt ();
7394 /* Disallow temp vars at this level. */
7395 current_binding_level
->prep_state
= 2;
7397 lineno
= old_lineno
;
7398 input_filename
= old_input_filename
;
7400 /* This handles any symbols still untransformed, in case -g specified.
7401 This used to be done in ffecom_finish_progunit, but it turns out to
7402 be necessary to do it here so that statement functions are
7403 expanded before code. But don't bother for BLOCK DATA. */
7405 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7406 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7410 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7413 ffecom_sym_transform_(s);
7415 The ffesymbol_hook info for s is updated with appropriate backend info
7418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7420 ffecom_sym_transform_ (ffesymbol s
)
7422 tree t
; /* Transformed thingy. */
7423 tree tlen
; /* Length if CHAR*(*). */
7424 bool addr
; /* Is t the address of the thingy? */
7425 ffeinfoBasictype bt
;
7428 int old_lineno
= lineno
;
7429 const char *old_input_filename
= input_filename
;
7431 /* Must ensure special ASSIGN variables are declared at top of outermost
7432 block, else they'll end up in the innermost block when their first
7433 ASSIGN is seen, which leaves them out of scope when they're the
7434 subject of a GOTO or I/O statement.
7436 We make this variable even if -fugly-assign. Just let it go unused,
7437 in case it turns out there are cases where we really want to use this
7438 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7440 if (! ffecom_transform_only_dummies_
7441 && ffesymbol_assigned (s
)
7442 && ! ffesymbol_hook (s
).assign_tree
)
7443 s
= ffecom_sym_transform_assign_ (s
);
7445 if (ffesymbol_sfdummyparent (s
) == NULL
)
7447 input_filename
= ffesymbol_where_filename (s
);
7448 lineno
= ffesymbol_where_filelinenum (s
);
7452 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7454 input_filename
= ffesymbol_where_filename (sf
);
7455 lineno
= ffesymbol_where_filelinenum (sf
);
7458 bt
= ffeinfo_basictype (ffebld_info (s
));
7459 kt
= ffeinfo_kindtype (ffebld_info (s
));
7465 switch (ffesymbol_kind (s
))
7467 case FFEINFO_kindNONE
:
7468 switch (ffesymbol_where (s
))
7470 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7471 assert (ffecom_transform_only_dummies_
);
7473 /* Before 0.4, this could be ENTITY/DUMMY, but see
7474 ffestu_sym_end_transition -- no longer true (in particular, if
7475 it could be an ENTITY, it _will_ be made one, so that
7476 possibility won't come through here). So we never make length
7477 arg for CHARACTER type. */
7479 t
= build_decl (PARM_DECL
,
7480 ffecom_get_identifier_ (ffesymbol_text (s
)),
7481 ffecom_tree_ptr_to_subr_type
);
7483 DECL_ARTIFICIAL (t
) = 1;
7488 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7489 assert (!ffecom_transform_only_dummies_
);
7491 if (((g
= ffesymbol_global (s
)) != NULL
)
7492 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7493 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7494 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7495 && (ffeglobal_hook (g
) != NULL_TREE
)
7496 && ffe_is_globals ())
7498 t
= ffeglobal_hook (g
);
7502 t
= build_decl (FUNCTION_DECL
,
7503 ffecom_get_external_identifier_ (s
),
7504 ffecom_tree_subr_type
); /* Assume subr. */
7505 DECL_EXTERNAL (t
) = 1;
7506 TREE_PUBLIC (t
) = 1;
7508 t
= start_decl (t
, FALSE
);
7509 finish_decl (t
, NULL_TREE
, FALSE
);
7512 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7513 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7514 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7515 ffeglobal_set_hook (g
, t
);
7517 ffecom_save_tree_forever (t
);
7522 assert ("NONE where unexpected" == NULL
);
7524 case FFEINFO_whereANY
:
7529 case FFEINFO_kindENTITY
:
7530 switch (ffeinfo_where (ffesymbol_info (s
)))
7533 case FFEINFO_whereCONSTANT
:
7534 /* ~~Debugging info needed? */
7535 assert (!ffecom_transform_only_dummies_
);
7536 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7539 case FFEINFO_whereLOCAL
:
7540 assert (!ffecom_transform_only_dummies_
);
7543 ffestorag st
= ffesymbol_storage (s
);
7547 && (ffestorag_size (st
) == 0))
7549 t
= error_mark_node
;
7553 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7555 if (type
== error_mark_node
)
7557 t
= error_mark_node
;
7562 && (ffestorag_parent (st
) != NULL
))
7563 { /* Child of EQUIVALENCE parent. */
7566 ffetargetOffset offset
;
7568 est
= ffestorag_parent (st
);
7569 ffecom_transform_equiv_ (est
);
7571 et
= ffestorag_hook (est
);
7572 assert (et
!= NULL_TREE
);
7574 if (! TREE_STATIC (et
))
7575 put_var_into_stack (et
);
7577 offset
= ffestorag_modulo (est
)
7578 + ffestorag_offset (ffesymbol_storage (s
))
7579 - ffestorag_offset (est
);
7581 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7583 /* (t_type *) (((char *) &et) + offset) */
7585 t
= convert (string_type_node
, /* (char *) */
7586 ffecom_1 (ADDR_EXPR
,
7587 build_pointer_type (TREE_TYPE (et
)),
7589 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7591 build_int_2 (offset
, 0));
7592 t
= convert (build_pointer_type (type
),
7594 TREE_CONSTANT (t
) = staticp (et
);
7601 bool init
= ffesymbol_is_init (s
);
7603 t
= build_decl (VAR_DECL
,
7604 ffecom_get_identifier_ (ffesymbol_text (s
)),
7608 || ffesymbol_namelisted (s
)
7609 #ifdef FFECOM_sizeMAXSTACKITEM
7611 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7613 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7614 && (ffecom_primary_entry_kind_
7615 != FFEINFO_kindBLOCKDATA
)
7616 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7617 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7619 TREE_STATIC (t
) = 0; /* No need to make static. */
7621 if (init
|| ffe_is_init_local_zero ())
7622 DECL_INITIAL (t
) = error_mark_node
;
7624 /* Keep -Wunused from complaining about var if it
7625 is used as sfunc arg or DATA implied-DO. */
7626 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7627 DECL_IN_SYSTEM_HEADER (t
) = 1;
7629 t
= start_decl (t
, FALSE
);
7633 if (ffesymbol_init (s
) != NULL
)
7634 initexpr
= ffecom_expr (ffesymbol_init (s
));
7636 initexpr
= ffecom_init_zero_ (t
);
7638 else if (ffe_is_init_local_zero ())
7639 initexpr
= ffecom_init_zero_ (t
);
7641 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7643 finish_decl (t
, initexpr
, FALSE
);
7645 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7647 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7648 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7649 ffestorag_size (st
)));
7655 case FFEINFO_whereRESULT
:
7656 assert (!ffecom_transform_only_dummies_
);
7658 if (bt
== FFEINFO_basictypeCHARACTER
)
7659 { /* Result is already in list of dummies, use
7661 t
= ffecom_func_result_
;
7662 tlen
= ffecom_func_length_
;
7666 if ((ffecom_num_entrypoints_
== 0)
7667 && (bt
== FFEINFO_basictypeCOMPLEX
)
7668 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7669 { /* Result is already in list of dummies, use
7671 t
= ffecom_func_result_
;
7675 if (ffecom_func_result_
!= NULL_TREE
)
7677 t
= ffecom_func_result_
;
7680 if ((ffecom_num_entrypoints_
!= 0)
7681 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7683 assert (ffecom_multi_retval_
!= NULL_TREE
);
7684 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7685 ffecom_multi_retval_
);
7686 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7687 t
, ffecom_multi_fields_
[bt
][kt
]);
7692 t
= build_decl (VAR_DECL
,
7693 ffecom_get_identifier_ (ffesymbol_text (s
)),
7694 ffecom_tree_type
[bt
][kt
]);
7695 TREE_STATIC (t
) = 0; /* Put result on stack. */
7696 t
= start_decl (t
, FALSE
);
7697 finish_decl (t
, NULL_TREE
, FALSE
);
7699 ffecom_func_result_
= t
;
7703 case FFEINFO_whereDUMMY
:
7711 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7713 type
= ffecom_tree_type
[bt
][kt
];
7714 if (ffesymbol_sfdummyparent (s
) != NULL
)
7716 if (current_function_decl
== ffecom_outer_function_decl_
)
7717 { /* Exec transition before sfunc
7718 context; get it later. */
7721 t
= ffecom_get_identifier_ (ffesymbol_text
7722 (ffesymbol_sfdummyparent (s
)));
7725 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7727 assert (ffecom_transform_only_dummies_
);
7729 old_sizes
= get_pending_sizes ();
7730 put_pending_sizes (old_sizes
);
7732 if (bt
== FFEINFO_basictypeCHARACTER
)
7733 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7734 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7736 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7738 if (type
== error_mark_node
)
7741 dim
= ffebld_head (dl
);
7742 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7743 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7744 low
= ffecom_integer_one_node
;
7746 low
= ffecom_expr (ffebld_left (dim
));
7747 assert (ffebld_right (dim
) != NULL
);
7748 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7749 || ffecom_doing_entry_
)
7751 /* Used to just do high=low. But for ffecom_tree_
7752 canonize_ref_, it probably is important to correctly
7753 assess the size. E.g. given COMPLEX C(*),CFUNC and
7754 C(2)=CFUNC(C), overlap can happen, while it can't
7755 for, say, C(1)=CFUNC(C(2)). */
7756 /* Even more recently used to set to INT_MAX, but that
7757 broke when some overflow checking went into the back
7758 end. Now we just leave the upper bound unspecified. */
7762 high
= ffecom_expr (ffebld_right (dim
));
7764 /* Determine whether array is conditionally adjustable,
7765 to decide whether back-end magic is needed.
7767 Normally the front end uses the back-end function
7768 variable_size to wrap SAVE_EXPR's around expressions
7769 affecting the size/shape of an array so that the
7770 size/shape info doesn't change during execution
7771 of the compiled code even though variables and
7772 functions referenced in those expressions might.
7774 variable_size also makes sure those saved expressions
7775 get evaluated immediately upon entry to the
7776 compiled procedure -- the front end normally doesn't
7777 have to worry about that.
7779 However, there is a problem with this that affects
7780 g77's implementation of entry points, and that is
7781 that it is _not_ true that each invocation of the
7782 compiled procedure is permitted to evaluate
7783 array size/shape info -- because it is possible
7784 that, for some invocations, that info is invalid (in
7785 which case it is "promised" -- i.e. a violation of
7786 the Fortran standard -- that the compiled code
7787 won't reference the array or its size/shape
7788 during that particular invocation).
7790 To phrase this in C terms, consider this gcc function:
7792 void foo (int *n, float (*a)[*n])
7794 // a is "pointer to array ...", fyi.
7797 Suppose that, for some invocations, it is permitted
7798 for a caller of foo to do this:
7802 Now the _written_ code for foo can take such a call
7803 into account by either testing explicitly for whether
7804 (a == NULL) || (n == NULL) -- presumably it is
7805 not permitted to reference *a in various fashions
7806 if (n == NULL) I suppose -- or it can avoid it by
7807 looking at other info (other arguments, static/global
7810 However, this won't work in gcc 2.5.8 because it'll
7811 automatically emit the code to save the "*n"
7812 expression, which'll yield a NULL dereference for
7813 the "foo (NULL, NULL)" call, something the code
7814 for foo cannot prevent.
7816 g77 definitely needs to avoid executing such
7817 code anytime the pointer to the adjustable array
7818 is NULL, because even if its bounds expressions
7819 don't have any references to possible "absent"
7820 variables like "*n" -- say all variable references
7821 are to COMMON variables, i.e. global (though in C,
7822 local static could actually make sense) -- the
7823 expressions could yield other run-time problems
7824 for allowably "dead" values in those variables.
7826 For example, let's consider a more complicated
7832 void foo (float (*a)[i/j])
7837 The above is (essentially) quite valid for Fortran
7838 but, again, for a call like "foo (NULL);", it is
7839 permitted for i and j to be undefined when the
7840 call is made. If j happened to be zero, for
7841 example, emitting the code to evaluate "i/j"
7842 could result in a run-time error.
7844 Offhand, though I don't have my F77 or F90
7845 standards handy, it might even be valid for a
7846 bounds expression to contain a function reference,
7847 in which case I doubt it is permitted for an
7848 implementation to invoke that function in the
7849 Fortran case involved here (invocation of an
7850 alternate ENTRY point that doesn't have the adjustable
7851 array as one of its arguments).
7853 So, the code that the compiler would normally emit
7854 to preevaluate the size/shape info for an
7855 adjustable array _must not_ be executed at run time
7856 in certain cases. Specifically, for Fortran,
7857 the case is when the pointer to the adjustable
7858 array == NULL. (For gnu-ish C, it might be nice
7859 for the source code itself to specify an expression
7860 that, if TRUE, inhibits execution of the code. Or
7861 reverse the sense for elegance.)
7863 (Note that g77 could use a different test than NULL,
7864 actually, since it happens to always pass an
7865 integer to the called function that specifies which
7866 entry point is being invoked. Hmm, this might
7867 solve the next problem.)
7869 One way a user could, I suppose, write "foo" so
7870 it works is to insert COND_EXPR's for the
7871 size/shape info so the dangerous stuff isn't
7872 actually done, as in:
7874 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7879 The next problem is that the front end needs to
7880 be able to tell the back end about the array's
7881 decl _before_ it tells it about the conditional
7882 expression to inhibit evaluation of size/shape info,
7885 To solve this, the front end needs to be able
7886 to give the back end the expression to inhibit
7887 generation of the preevaluation code _after_
7888 it makes the decl for the adjustable array.
7890 Until then, the above example using the COND_EXPR
7891 doesn't pass muster with gcc because the "(a == NULL)"
7892 part has a reference to "a", which is still
7893 undefined at that point.
7895 g77 will therefore use a different mechanism in the
7899 && ((TREE_CODE (low
) != INTEGER_CST
)
7900 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7903 #if 0 /* Old approach -- see below. */
7904 if (TREE_CODE (low
) != INTEGER_CST
)
7905 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7906 ffecom_adjarray_passed_ (s
),
7908 ffecom_integer_zero_node
);
7910 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7911 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7912 ffecom_adjarray_passed_ (s
),
7914 ffecom_integer_zero_node
);
7917 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7918 probably. Fixes 950302-1.f. */
7920 if (TREE_CODE (low
) != INTEGER_CST
)
7921 low
= variable_size (low
);
7923 /* ~~~Similarly, this fixes dumb0.f. The C front end
7924 does this, which is why dumb0.c would work. */
7926 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7927 high
= variable_size (high
);
7932 build_range_type (ffecom_integer_type_node
,
7934 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7937 if (type
== error_mark_node
)
7939 t
= error_mark_node
;
7943 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7944 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7946 type
= build_pointer_type (type
);
7950 t
= build_decl (PARM_DECL
, t
, type
);
7952 DECL_ARTIFICIAL (t
) = 1;
7955 /* If this arg is present in every entry point's list of
7956 dummy args, then we're done. */
7958 if (ffesymbol_numentries (s
)
7959 == (ffecom_num_entrypoints_
+ 1))
7964 /* If variable_size in stor-layout has been called during
7965 the above, then get_pending_sizes should have the
7966 yet-to-be-evaluated saved expressions pending.
7967 Make the whole lot of them get emitted, conditionally
7968 on whether the array decl ("t" above) is not NULL. */
7971 tree sizes
= get_pending_sizes ();
7976 tem
= TREE_CHAIN (tem
))
7978 tree temv
= TREE_VALUE (tem
);
7984 = ffecom_2 (COMPOUND_EXPR
,
7993 = ffecom_3 (COND_EXPR
,
8000 convert (TREE_TYPE (sizes
),
8001 integer_zero_node
));
8002 sizes
= ffecom_save_tree (sizes
);
8005 = tree_cons (NULL_TREE
, sizes
, tem
);
8009 put_pending_sizes (sizes
);
8015 && (ffesymbol_numentries (s
)
8016 != ffecom_num_entrypoints_
+ 1))
8018 = ffecom_2 (NE_EXPR
, integer_type_node
,
8024 && (ffesymbol_numentries (s
)
8025 != ffecom_num_entrypoints_
+ 1))
8027 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8028 ffebad_here (0, ffesymbol_where_line (s
),
8029 ffesymbol_where_column (s
));
8030 ffebad_string (ffesymbol_text (s
));
8039 case FFEINFO_whereCOMMON
:
8044 ffestorag st
= ffesymbol_storage (s
);
8047 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8048 if (st
!= NULL
) /* Else not laid out. */
8050 ffecom_transform_common_ (cs
);
8051 st
= ffesymbol_storage (s
);
8054 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8056 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8058 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8061 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8063 if ((ct
== NULL_TREE
)
8065 || (type
== error_mark_node
))
8066 t
= error_mark_node
;
8069 ffetargetOffset offset
;
8072 cst
= ffestorag_parent (st
);
8073 assert (cst
== ffesymbol_storage (cs
));
8075 offset
= ffestorag_modulo (cst
)
8076 + ffestorag_offset (st
)
8077 - ffestorag_offset (cst
);
8079 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8081 /* (t_type *) (((char *) &ct) + offset) */
8083 t
= convert (string_type_node
, /* (char *) */
8084 ffecom_1 (ADDR_EXPR
,
8085 build_pointer_type (TREE_TYPE (ct
)),
8087 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8089 build_int_2 (offset
, 0));
8090 t
= convert (build_pointer_type (type
),
8092 TREE_CONSTANT (t
) = 1;
8099 case FFEINFO_whereIMMEDIATE
:
8100 case FFEINFO_whereGLOBAL
:
8101 case FFEINFO_whereFLEETING
:
8102 case FFEINFO_whereFLEETING_CADDR
:
8103 case FFEINFO_whereFLEETING_IADDR
:
8104 case FFEINFO_whereINTRINSIC
:
8105 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8107 assert ("ENTITY where unheard of" == NULL
);
8109 case FFEINFO_whereANY
:
8110 t
= error_mark_node
;
8115 case FFEINFO_kindFUNCTION
:
8116 switch (ffeinfo_where (ffesymbol_info (s
)))
8118 case FFEINFO_whereLOCAL
: /* Me. */
8119 assert (!ffecom_transform_only_dummies_
);
8120 t
= current_function_decl
;
8123 case FFEINFO_whereGLOBAL
:
8124 assert (!ffecom_transform_only_dummies_
);
8126 if (((g
= ffesymbol_global (s
)) != NULL
)
8127 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8128 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8129 && (ffeglobal_hook (g
) != NULL_TREE
)
8130 && ffe_is_globals ())
8132 t
= ffeglobal_hook (g
);
8136 if (ffesymbol_is_f2c (s
)
8137 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8138 t
= ffecom_tree_fun_type
[bt
][kt
];
8140 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8142 t
= build_decl (FUNCTION_DECL
,
8143 ffecom_get_external_identifier_ (s
),
8145 DECL_EXTERNAL (t
) = 1;
8146 TREE_PUBLIC (t
) = 1;
8148 t
= start_decl (t
, FALSE
);
8149 finish_decl (t
, NULL_TREE
, FALSE
);
8152 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8153 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8154 ffeglobal_set_hook (g
, t
);
8156 ffecom_save_tree_forever (t
);
8160 case FFEINFO_whereDUMMY
:
8161 assert (ffecom_transform_only_dummies_
);
8163 if (ffesymbol_is_f2c (s
)
8164 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8165 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8167 t
= build_pointer_type
8168 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8170 t
= build_decl (PARM_DECL
,
8171 ffecom_get_identifier_ (ffesymbol_text (s
)),
8174 DECL_ARTIFICIAL (t
) = 1;
8179 case FFEINFO_whereCONSTANT
: /* Statement function. */
8180 assert (!ffecom_transform_only_dummies_
);
8181 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8184 case FFEINFO_whereINTRINSIC
:
8185 assert (!ffecom_transform_only_dummies_
);
8186 break; /* Let actual references generate their
8190 assert ("FUNCTION where unheard of" == NULL
);
8192 case FFEINFO_whereANY
:
8193 t
= error_mark_node
;
8198 case FFEINFO_kindSUBROUTINE
:
8199 switch (ffeinfo_where (ffesymbol_info (s
)))
8201 case FFEINFO_whereLOCAL
: /* Me. */
8202 assert (!ffecom_transform_only_dummies_
);
8203 t
= current_function_decl
;
8206 case FFEINFO_whereGLOBAL
:
8207 assert (!ffecom_transform_only_dummies_
);
8209 if (((g
= ffesymbol_global (s
)) != NULL
)
8210 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8211 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8212 && (ffeglobal_hook (g
) != NULL_TREE
)
8213 && ffe_is_globals ())
8215 t
= ffeglobal_hook (g
);
8219 t
= build_decl (FUNCTION_DECL
,
8220 ffecom_get_external_identifier_ (s
),
8221 ffecom_tree_subr_type
);
8222 DECL_EXTERNAL (t
) = 1;
8223 TREE_PUBLIC (t
) = 1;
8225 t
= start_decl (t
, FALSE
);
8226 finish_decl (t
, NULL_TREE
, FALSE
);
8229 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8230 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8231 ffeglobal_set_hook (g
, t
);
8233 ffecom_save_tree_forever (t
);
8237 case FFEINFO_whereDUMMY
:
8238 assert (ffecom_transform_only_dummies_
);
8240 t
= build_decl (PARM_DECL
,
8241 ffecom_get_identifier_ (ffesymbol_text (s
)),
8242 ffecom_tree_ptr_to_subr_type
);
8244 DECL_ARTIFICIAL (t
) = 1;
8249 case FFEINFO_whereINTRINSIC
:
8250 assert (!ffecom_transform_only_dummies_
);
8251 break; /* Let actual references generate their
8255 assert ("SUBROUTINE where unheard of" == NULL
);
8257 case FFEINFO_whereANY
:
8258 t
= error_mark_node
;
8263 case FFEINFO_kindPROGRAM
:
8264 switch (ffeinfo_where (ffesymbol_info (s
)))
8266 case FFEINFO_whereLOCAL
: /* Me. */
8267 assert (!ffecom_transform_only_dummies_
);
8268 t
= current_function_decl
;
8271 case FFEINFO_whereCOMMON
:
8272 case FFEINFO_whereDUMMY
:
8273 case FFEINFO_whereGLOBAL
:
8274 case FFEINFO_whereRESULT
:
8275 case FFEINFO_whereFLEETING
:
8276 case FFEINFO_whereFLEETING_CADDR
:
8277 case FFEINFO_whereFLEETING_IADDR
:
8278 case FFEINFO_whereIMMEDIATE
:
8279 case FFEINFO_whereINTRINSIC
:
8280 case FFEINFO_whereCONSTANT
:
8281 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8283 assert ("PROGRAM where unheard of" == NULL
);
8285 case FFEINFO_whereANY
:
8286 t
= error_mark_node
;
8291 case FFEINFO_kindBLOCKDATA
:
8292 switch (ffeinfo_where (ffesymbol_info (s
)))
8294 case FFEINFO_whereLOCAL
: /* Me. */
8295 assert (!ffecom_transform_only_dummies_
);
8296 t
= current_function_decl
;
8299 case FFEINFO_whereGLOBAL
:
8300 assert (!ffecom_transform_only_dummies_
);
8302 t
= build_decl (FUNCTION_DECL
,
8303 ffecom_get_external_identifier_ (s
),
8304 ffecom_tree_blockdata_type
);
8305 DECL_EXTERNAL (t
) = 1;
8306 TREE_PUBLIC (t
) = 1;
8308 t
= start_decl (t
, FALSE
);
8309 finish_decl (t
, NULL_TREE
, FALSE
);
8311 ffecom_save_tree_forever (t
);
8315 case FFEINFO_whereCOMMON
:
8316 case FFEINFO_whereDUMMY
:
8317 case FFEINFO_whereRESULT
:
8318 case FFEINFO_whereFLEETING
:
8319 case FFEINFO_whereFLEETING_CADDR
:
8320 case FFEINFO_whereFLEETING_IADDR
:
8321 case FFEINFO_whereIMMEDIATE
:
8322 case FFEINFO_whereINTRINSIC
:
8323 case FFEINFO_whereCONSTANT
:
8324 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8326 assert ("BLOCKDATA where unheard of" == NULL
);
8328 case FFEINFO_whereANY
:
8329 t
= error_mark_node
;
8334 case FFEINFO_kindCOMMON
:
8335 switch (ffeinfo_where (ffesymbol_info (s
)))
8337 case FFEINFO_whereLOCAL
:
8338 assert (!ffecom_transform_only_dummies_
);
8339 ffecom_transform_common_ (s
);
8342 case FFEINFO_whereNONE
:
8343 case FFEINFO_whereCOMMON
:
8344 case FFEINFO_whereDUMMY
:
8345 case FFEINFO_whereGLOBAL
:
8346 case FFEINFO_whereRESULT
:
8347 case FFEINFO_whereFLEETING
:
8348 case FFEINFO_whereFLEETING_CADDR
:
8349 case FFEINFO_whereFLEETING_IADDR
:
8350 case FFEINFO_whereIMMEDIATE
:
8351 case FFEINFO_whereINTRINSIC
:
8352 case FFEINFO_whereCONSTANT
:
8353 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8355 assert ("COMMON where unheard of" == NULL
);
8357 case FFEINFO_whereANY
:
8358 t
= error_mark_node
;
8363 case FFEINFO_kindCONSTRUCT
:
8364 switch (ffeinfo_where (ffesymbol_info (s
)))
8366 case FFEINFO_whereLOCAL
:
8367 assert (!ffecom_transform_only_dummies_
);
8370 case FFEINFO_whereNONE
:
8371 case FFEINFO_whereCOMMON
:
8372 case FFEINFO_whereDUMMY
:
8373 case FFEINFO_whereGLOBAL
:
8374 case FFEINFO_whereRESULT
:
8375 case FFEINFO_whereFLEETING
:
8376 case FFEINFO_whereFLEETING_CADDR
:
8377 case FFEINFO_whereFLEETING_IADDR
:
8378 case FFEINFO_whereIMMEDIATE
:
8379 case FFEINFO_whereINTRINSIC
:
8380 case FFEINFO_whereCONSTANT
:
8381 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8383 assert ("CONSTRUCT where unheard of" == NULL
);
8385 case FFEINFO_whereANY
:
8386 t
= error_mark_node
;
8391 case FFEINFO_kindNAMELIST
:
8392 switch (ffeinfo_where (ffesymbol_info (s
)))
8394 case FFEINFO_whereLOCAL
:
8395 assert (!ffecom_transform_only_dummies_
);
8396 t
= ffecom_transform_namelist_ (s
);
8399 case FFEINFO_whereNONE
:
8400 case FFEINFO_whereCOMMON
:
8401 case FFEINFO_whereDUMMY
:
8402 case FFEINFO_whereGLOBAL
:
8403 case FFEINFO_whereRESULT
:
8404 case FFEINFO_whereFLEETING
:
8405 case FFEINFO_whereFLEETING_CADDR
:
8406 case FFEINFO_whereFLEETING_IADDR
:
8407 case FFEINFO_whereIMMEDIATE
:
8408 case FFEINFO_whereINTRINSIC
:
8409 case FFEINFO_whereCONSTANT
:
8410 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8412 assert ("NAMELIST where unheard of" == NULL
);
8414 case FFEINFO_whereANY
:
8415 t
= error_mark_node
;
8421 assert ("kind unheard of" == NULL
);
8423 case FFEINFO_kindANY
:
8424 t
= error_mark_node
;
8428 ffesymbol_hook (s
).decl_tree
= t
;
8429 ffesymbol_hook (s
).length_tree
= tlen
;
8430 ffesymbol_hook (s
).addr
= addr
;
8432 lineno
= old_lineno
;
8433 input_filename
= old_input_filename
;
8439 /* Transform into ASSIGNable symbol.
8441 Symbol has already been transformed, but for whatever reason, the
8442 resulting decl_tree has been deemed not usable for an ASSIGN target.
8443 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8444 another local symbol of type void * and stuff that in the assign_tree
8445 argument. The F77/F90 standards allow this implementation. */
8447 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8449 ffecom_sym_transform_assign_ (ffesymbol s
)
8451 tree t
; /* Transformed thingy. */
8452 int old_lineno
= lineno
;
8453 const char *old_input_filename
= input_filename
;
8455 if (ffesymbol_sfdummyparent (s
) == NULL
)
8457 input_filename
= ffesymbol_where_filename (s
);
8458 lineno
= ffesymbol_where_filelinenum (s
);
8462 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8464 input_filename
= ffesymbol_where_filename (sf
);
8465 lineno
= ffesymbol_where_filelinenum (sf
);
8468 assert (!ffecom_transform_only_dummies_
);
8470 t
= build_decl (VAR_DECL
,
8471 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8472 ffesymbol_text (s
)),
8473 TREE_TYPE (null_pointer_node
));
8475 switch (ffesymbol_where (s
))
8477 case FFEINFO_whereLOCAL
:
8478 /* Unlike for regular vars, SAVE status is easy to determine for
8479 ASSIGNed vars, since there's no initialization, there's no
8480 effective storage association (so "SAVE J" does not apply to
8481 K even given "EQUIVALENCE (J,K)"), there's no size issue
8482 to worry about, etc. */
8483 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8484 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8485 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8486 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8488 TREE_STATIC (t
) = 0; /* No need to make static. */
8491 case FFEINFO_whereCOMMON
:
8492 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8495 case FFEINFO_whereDUMMY
:
8496 /* Note that twinning a DUMMY means the caller won't see
8497 the ASSIGNed value. But both F77 and F90 allow implementations
8498 to do this, i.e. disallow Fortran code that would try and
8499 take advantage of actually putting a label into a variable
8500 via a dummy argument (or any other storage association, for
8502 TREE_STATIC (t
) = 0;
8506 TREE_STATIC (t
) = 0;
8510 t
= start_decl (t
, FALSE
);
8511 finish_decl (t
, NULL_TREE
, FALSE
);
8513 ffesymbol_hook (s
).assign_tree
= t
;
8515 lineno
= old_lineno
;
8516 input_filename
= old_input_filename
;
8522 /* Implement COMMON area in back end.
8524 Because COMMON-based variables can be referenced in the dimension
8525 expressions of dummy (adjustable) arrays, and because dummies
8526 (in the gcc back end) need to be put in the outer binding level
8527 of a function (which has two binding levels, the outer holding
8528 the dummies and the inner holding the other vars), special care
8529 must be taken to handle COMMON areas.
8531 The current strategy is basically to always tell the back end about
8532 the COMMON area as a top-level external reference to just a block
8533 of storage of the master type of that area (e.g. integer, real,
8534 character, whatever -- not a structure). As a distinct action,
8535 if initial values are provided, tell the back end about the area
8536 as a top-level non-external (initialized) area and remember not to
8537 allow further initialization or expansion of the area. Meanwhile,
8538 if no initialization happens at all, tell the back end about
8539 the largest size we've seen declared so the space does get reserved.
8540 (This function doesn't handle all that stuff, but it does some
8541 of the important things.)
8543 Meanwhile, for COMMON variables themselves, just keep creating
8544 references like *((float *) (&common_area + offset)) each time
8545 we reference the variable. In other words, don't make a VAR_DECL
8546 or any kind of component reference (like we used to do before 0.4),
8547 though we might do that as well just for debugging purposes (and
8548 stuff the rtl with the appropriate offset expression). */
8550 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8552 ffecom_transform_common_ (ffesymbol s
)
8554 ffestorag st
= ffesymbol_storage (s
);
8555 ffeglobal g
= ffesymbol_global (s
);
8560 bool is_init
= ffestorag_is_init (st
);
8562 assert (st
!= NULL
);
8565 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8568 /* First update the size of the area in global terms. */
8570 ffeglobal_size_common (s
, ffestorag_size (st
));
8572 if (!ffeglobal_common_init (g
))
8573 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8575 cbt
= ffeglobal_hook (g
);
8577 /* If we already have declared this common block for a previous program
8578 unit, and either we already initialized it or we don't have new
8579 initialization for it, just return what we have without changing it. */
8581 if ((cbt
!= NULL_TREE
)
8583 || !DECL_EXTERNAL (cbt
)))
8585 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8589 /* Process inits. */
8593 if (ffestorag_init (st
) != NULL
)
8597 /* Set the padding for the expression, so ffecom_expr
8598 knows to insert that many zeros. */
8599 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8601 case FFEBLD_opCONTER
:
8602 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8605 case FFEBLD_opARRTER
:
8606 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8609 case FFEBLD_opACCTER
:
8610 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8614 assert ("bad op for cmn init (pad)" == NULL
);
8618 init
= ffecom_expr (sexp
);
8619 if (init
== error_mark_node
)
8620 { /* Hopefully the back end complained! */
8622 if (cbt
!= NULL_TREE
)
8627 init
= error_mark_node
;
8632 /* cbtype must be permanently allocated! */
8634 /* Allocate the MAX of the areas so far, seen filewide. */
8635 high
= build_int_2 ((ffeglobal_common_size (g
)
8636 + ffeglobal_common_pad (g
)) - 1, 0);
8637 TREE_TYPE (high
) = ffecom_integer_type_node
;
8640 cbtype
= build_array_type (char_type_node
,
8641 build_range_type (integer_type_node
,
8645 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8647 if (cbt
== NULL_TREE
)
8650 = build_decl (VAR_DECL
,
8651 ffecom_get_external_identifier_ (s
),
8653 TREE_STATIC (cbt
) = 1;
8654 TREE_PUBLIC (cbt
) = 1;
8659 TREE_TYPE (cbt
) = cbtype
;
8661 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8662 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8664 cbt
= start_decl (cbt
, TRUE
);
8665 if (ffeglobal_hook (g
) != NULL
)
8666 assert (cbt
== ffeglobal_hook (g
));
8668 assert (!init
|| !DECL_EXTERNAL (cbt
));
8670 /* Make sure that any type can live in COMMON and be referenced
8671 without getting a bus error. We could pick the most restrictive
8672 alignment of all entities actually placed in the COMMON, but
8673 this seems easy enough. */
8675 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8676 DECL_USER_ALIGN (cbt
) = 0;
8678 if (is_init
&& (ffestorag_init (st
) == NULL
))
8679 init
= ffecom_init_zero_ (cbt
);
8681 finish_decl (cbt
, init
, TRUE
);
8684 ffestorag_set_init (st
, ffebld_new_any ());
8688 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8689 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8690 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8691 (ffeglobal_common_size (g
)
8692 + ffeglobal_common_pad (g
))));
8695 ffeglobal_set_hook (g
, cbt
);
8697 ffestorag_set_hook (st
, cbt
);
8699 ffecom_save_tree_forever (cbt
);
8703 /* Make master area for local EQUIVALENCE. */
8705 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8707 ffecom_transform_equiv_ (ffestorag eqst
)
8713 bool is_init
= ffestorag_is_init (eqst
);
8715 assert (eqst
!= NULL
);
8717 eqt
= ffestorag_hook (eqst
);
8719 if (eqt
!= NULL_TREE
)
8722 /* Process inits. */
8726 if (ffestorag_init (eqst
) != NULL
)
8730 /* Set the padding for the expression, so ffecom_expr
8731 knows to insert that many zeros. */
8732 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8734 case FFEBLD_opCONTER
:
8735 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8738 case FFEBLD_opARRTER
:
8739 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8742 case FFEBLD_opACCTER
:
8743 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8747 assert ("bad op for eqv init (pad)" == NULL
);
8751 init
= ffecom_expr (sexp
);
8752 if (init
== error_mark_node
)
8753 init
= NULL_TREE
; /* Hopefully the back end complained! */
8756 init
= error_mark_node
;
8758 else if (ffe_is_init_local_zero ())
8759 init
= error_mark_node
;
8763 ffecom_member_namelisted_
= FALSE
;
8764 ffestorag_drive (ffestorag_list_equivs (eqst
),
8765 &ffecom_member_phase1_
,
8768 high
= build_int_2 ((ffestorag_size (eqst
)
8769 + ffestorag_modulo (eqst
)) - 1, 0);
8770 TREE_TYPE (high
) = ffecom_integer_type_node
;
8772 eqtype
= build_array_type (char_type_node
,
8773 build_range_type (ffecom_integer_type_node
,
8774 ffecom_integer_zero_node
,
8777 eqt
= build_decl (VAR_DECL
,
8778 ffecom_get_invented_identifier ("__g77_equiv_%s",
8780 (ffestorag_symbol (eqst
))),
8782 DECL_EXTERNAL (eqt
) = 0;
8784 || ffecom_member_namelisted_
8785 #ifdef FFECOM_sizeMAXSTACKITEM
8786 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8788 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8789 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8790 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8791 TREE_STATIC (eqt
) = 1;
8793 TREE_STATIC (eqt
) = 0;
8794 TREE_PUBLIC (eqt
) = 0;
8795 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8796 DECL_CONTEXT (eqt
) = current_function_decl
;
8798 DECL_INITIAL (eqt
) = error_mark_node
;
8800 DECL_INITIAL (eqt
) = NULL_TREE
;
8802 eqt
= start_decl (eqt
, FALSE
);
8804 /* Make sure that any type can live in EQUIVALENCE and be referenced
8805 without getting a bus error. We could pick the most restrictive
8806 alignment of all entities actually placed in the EQUIVALENCE, but
8807 this seems easy enough. */
8809 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8810 DECL_USER_ALIGN (eqt
) = 0;
8812 if ((!is_init
&& ffe_is_init_local_zero ())
8813 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8814 init
= ffecom_init_zero_ (eqt
);
8816 finish_decl (eqt
, init
, FALSE
);
8819 ffestorag_set_init (eqst
, ffebld_new_any ());
8822 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8823 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8824 (ffestorag_size (eqst
)
8825 + ffestorag_modulo (eqst
))));
8828 ffestorag_set_hook (eqst
, eqt
);
8830 ffestorag_drive (ffestorag_list_equivs (eqst
),
8831 &ffecom_member_phase2_
,
8836 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8840 ffecom_transform_namelist_ (ffesymbol s
)
8843 tree nmltype
= ffecom_type_namelist_ ();
8851 static int mynumber
= 0;
8853 nmlt
= build_decl (VAR_DECL
,
8854 ffecom_get_invented_identifier ("__g77_namelist_%d",
8857 TREE_STATIC (nmlt
) = 1;
8858 DECL_INITIAL (nmlt
) = error_mark_node
;
8860 nmlt
= start_decl (nmlt
, FALSE
);
8862 /* Process inits. */
8864 i
= strlen (ffesymbol_text (s
));
8866 high
= build_int_2 (i
, 0);
8867 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8869 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8870 ffesymbol_text (s
));
8871 TREE_TYPE (nameinit
)
8872 = build_type_variant
8875 build_range_type (ffecom_f2c_ftnlen_type_node
,
8876 ffecom_f2c_ftnlen_one_node
,
8879 TREE_CONSTANT (nameinit
) = 1;
8880 TREE_STATIC (nameinit
) = 1;
8881 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8884 varsinit
= ffecom_vardesc_array_ (s
);
8885 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8887 TREE_CONSTANT (varsinit
) = 1;
8888 TREE_STATIC (varsinit
) = 1;
8893 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8896 nvarsinit
= build_int_2 (i
, 0);
8897 TREE_TYPE (nvarsinit
) = integer_type_node
;
8898 TREE_CONSTANT (nvarsinit
) = 1;
8899 TREE_STATIC (nvarsinit
) = 1;
8901 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8902 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8904 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8905 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8907 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8908 TREE_CONSTANT (nmlinits
) = 1;
8909 TREE_STATIC (nmlinits
) = 1;
8911 finish_decl (nmlt
, nmlinits
, FALSE
);
8913 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8920 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8921 analyzed on the assumption it is calculating a pointer to be
8922 indirected through. It must return the proper decl and offset,
8923 taking into account different units of measurements for offsets. */
8925 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8927 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8930 switch (TREE_CODE (t
))
8934 case NON_LVALUE_EXPR
:
8935 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8939 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8940 if ((*decl
== NULL_TREE
)
8941 || (*decl
== error_mark_node
))
8944 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8946 /* An offset into COMMON. */
8947 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8948 *offset
, TREE_OPERAND (t
, 1)));
8949 /* Convert offset (presumably in bytes) into canonical units
8950 (presumably bits). */
8951 *offset
= size_binop (MULT_EXPR
,
8952 convert (bitsizetype
, *offset
),
8953 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8956 /* Not a COMMON reference, so an unrecognized pattern. */
8957 *decl
= error_mark_node
;
8962 *offset
= bitsize_zero_node
;
8966 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8968 /* A reference to COMMON. */
8969 *decl
= TREE_OPERAND (t
, 0);
8970 *offset
= bitsize_zero_node
;
8975 /* Not a COMMON reference, so an unrecognized pattern. */
8976 *decl
= error_mark_node
;
8982 /* Given a tree that is possibly intended for use as an lvalue, return
8983 information representing a canonical view of that tree as a decl, an
8984 offset into that decl, and a size for the lvalue.
8986 If there's no applicable decl, NULL_TREE is returned for the decl,
8987 and the other fields are left undefined.
8989 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8990 is returned for the decl, and the other fields are left undefined.
8992 Otherwise, the decl returned currently is either a VAR_DECL or a
8995 The offset returned is always valid, but of course not necessarily
8996 a constant, and not necessarily converted into the appropriate
8997 type, leaving that up to the caller (so as to avoid that overhead
8998 if the decls being looked at are different anyway).
9000 If the size cannot be determined (e.g. an adjustable array),
9001 an ERROR_MARK node is returned for the size. Otherwise, the
9002 size returned is valid, not necessarily a constant, and not
9003 necessarily converted into the appropriate type as with the
9006 Note that the offset and size expressions are expressed in the
9007 base storage units (usually bits) rather than in the units of
9008 the type of the decl, because two decls with different types
9009 might overlap but with apparently non-overlapping array offsets,
9010 whereas converting the array offsets to consistant offsets will
9011 reveal the overlap. */
9013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9015 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9018 /* The default path is to report a nonexistant decl. */
9024 switch (TREE_CODE (t
))
9027 case IDENTIFIER_NODE
:
9036 case TRUNC_DIV_EXPR
:
9038 case FLOOR_DIV_EXPR
:
9039 case ROUND_DIV_EXPR
:
9040 case TRUNC_MOD_EXPR
:
9042 case FLOOR_MOD_EXPR
:
9043 case ROUND_MOD_EXPR
:
9045 case EXACT_DIV_EXPR
:
9046 case FIX_TRUNC_EXPR
:
9048 case FIX_FLOOR_EXPR
:
9049 case FIX_ROUND_EXPR
:
9064 case BIT_ANDTC_EXPR
:
9066 case TRUTH_ANDIF_EXPR
:
9067 case TRUTH_ORIF_EXPR
:
9068 case TRUTH_AND_EXPR
:
9070 case TRUTH_XOR_EXPR
:
9071 case TRUTH_NOT_EXPR
:
9091 *offset
= bitsize_zero_node
;
9092 *size
= TYPE_SIZE (TREE_TYPE (t
));
9097 tree array
= TREE_OPERAND (t
, 0);
9098 tree element
= TREE_OPERAND (t
, 1);
9101 if ((array
== NULL_TREE
)
9102 || (element
== NULL_TREE
))
9104 *decl
= error_mark_node
;
9108 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9110 if ((*decl
== NULL_TREE
)
9111 || (*decl
== error_mark_node
))
9114 /* Calculate ((element - base) * NBBY) + init_offset. */
9115 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
9117 TYPE_MIN_VALUE (TYPE_DOMAIN
9118 (TREE_TYPE (array
)))));
9120 *offset
= size_binop (MULT_EXPR
,
9121 convert (bitsizetype
, *offset
),
9122 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
9124 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
9126 *size
= TYPE_SIZE (TREE_TYPE (t
));
9132 /* Most of this code is to handle references to COMMON. And so
9133 far that is useful only for calling library functions, since
9134 external (user) functions might reference common areas. But
9135 even calling an external function, it's worthwhile to decode
9136 COMMON references because if not storing into COMMON, we don't
9137 want COMMON-based arguments to gratuitously force use of a
9140 *size
= TYPE_SIZE (TREE_TYPE (t
));
9142 ffecom_tree_canonize_ptr_ (decl
, offset
,
9143 TREE_OPERAND (t
, 0));
9150 case NON_LVALUE_EXPR
:
9153 case COND_EXPR
: /* More cases than we can handle. */
9155 case REFERENCE_EXPR
:
9156 case PREDECREMENT_EXPR
:
9157 case PREINCREMENT_EXPR
:
9158 case POSTDECREMENT_EXPR
:
9159 case POSTINCREMENT_EXPR
:
9162 *decl
= error_mark_node
;
9168 /* Do divide operation appropriate to type of operands. */
9170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9172 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9173 tree dest_tree
, ffebld dest
, bool *dest_used
,
9176 if ((left
== error_mark_node
)
9177 || (right
== error_mark_node
))
9178 return error_mark_node
;
9180 switch (TREE_CODE (tree_type
))
9183 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9188 if (! optimize_size
)
9189 return ffecom_2 (RDIV_EXPR
, tree_type
,
9195 if (TREE_TYPE (tree_type
)
9196 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9197 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9199 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9201 left
= ffecom_1 (ADDR_EXPR
,
9202 build_pointer_type (TREE_TYPE (left
)),
9204 left
= build_tree_list (NULL_TREE
, left
);
9205 right
= ffecom_1 (ADDR_EXPR
,
9206 build_pointer_type (TREE_TYPE (right
)),
9208 right
= build_tree_list (NULL_TREE
, right
);
9209 TREE_CHAIN (left
) = right
;
9211 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9212 ffecom_gfrt_kindtype (ix
),
9213 ffe_is_f2c_library (),
9216 dest_tree
, dest
, dest_used
,
9217 NULL_TREE
, TRUE
, hook
);
9225 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9226 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9227 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9229 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9231 left
= ffecom_1 (ADDR_EXPR
,
9232 build_pointer_type (TREE_TYPE (left
)),
9234 left
= build_tree_list (NULL_TREE
, left
);
9235 right
= ffecom_1 (ADDR_EXPR
,
9236 build_pointer_type (TREE_TYPE (right
)),
9238 right
= build_tree_list (NULL_TREE
, right
);
9239 TREE_CHAIN (left
) = right
;
9241 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9242 ffecom_gfrt_kindtype (ix
),
9243 ffe_is_f2c_library (),
9246 dest_tree
, dest
, dest_used
,
9247 NULL_TREE
, TRUE
, hook
);
9252 return ffecom_2 (RDIV_EXPR
, tree_type
,
9259 /* Build type info for non-dummy variable. */
9261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9263 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9272 type
= ffecom_tree_type
[bt
][kt
];
9273 if (bt
== FFEINFO_basictypeCHARACTER
)
9275 hight
= build_int_2 (ffesymbol_size (s
), 0);
9276 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9281 build_range_type (ffecom_f2c_ftnlen_type_node
,
9282 ffecom_f2c_ftnlen_one_node
,
9284 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9287 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9289 if (type
== error_mark_node
)
9292 dim
= ffebld_head (dl
);
9293 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9295 if (ffebld_left (dim
) == NULL
)
9296 lowt
= integer_one_node
;
9298 lowt
= ffecom_expr (ffebld_left (dim
));
9300 if (TREE_CODE (lowt
) != INTEGER_CST
)
9301 lowt
= variable_size (lowt
);
9303 assert (ffebld_right (dim
) != NULL
);
9304 hight
= ffecom_expr (ffebld_right (dim
));
9306 if (TREE_CODE (hight
) != INTEGER_CST
)
9307 hight
= variable_size (hight
);
9309 type
= build_array_type (type
,
9310 build_range_type (ffecom_integer_type_node
,
9312 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9319 /* Build Namelist type. */
9321 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9323 ffecom_type_namelist_ ()
9325 static tree type
= NULL_TREE
;
9327 if (type
== NULL_TREE
)
9329 static tree namefield
, varsfield
, nvarsfield
;
9332 vardesctype
= ffecom_type_vardesc_ ();
9334 type
= make_node (RECORD_TYPE
);
9336 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9338 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9340 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9341 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9344 TYPE_FIELDS (type
) = namefield
;
9347 ggc_add_tree_root (&type
, 1);
9355 /* Build Vardesc type. */
9357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9359 ffecom_type_vardesc_ ()
9361 static tree type
= NULL_TREE
;
9362 static tree namefield
, addrfield
, dimsfield
, typefield
;
9364 if (type
== NULL_TREE
)
9366 type
= make_node (RECORD_TYPE
);
9368 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9370 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9372 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9373 ffecom_f2c_ptr_to_ftnlen_type_node
);
9374 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9377 TYPE_FIELDS (type
) = namefield
;
9380 ggc_add_tree_root (&type
, 1);
9388 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9390 ffecom_vardesc_ (ffebld expr
)
9394 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9395 s
= ffebld_symter (expr
);
9397 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9400 tree vardesctype
= ffecom_type_vardesc_ ();
9408 static int mynumber
= 0;
9410 var
= build_decl (VAR_DECL
,
9411 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9414 TREE_STATIC (var
) = 1;
9415 DECL_INITIAL (var
) = error_mark_node
;
9417 var
= start_decl (var
, FALSE
);
9419 /* Process inits. */
9421 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9423 ffesymbol_text (s
));
9424 TREE_TYPE (nameinit
)
9425 = build_type_variant
9428 build_range_type (integer_type_node
,
9430 build_int_2 (i
, 0))),
9432 TREE_CONSTANT (nameinit
) = 1;
9433 TREE_STATIC (nameinit
) = 1;
9434 nameinit
= ffecom_1 (ADDR_EXPR
,
9435 build_pointer_type (TREE_TYPE (nameinit
)),
9438 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9440 dimsinit
= ffecom_vardesc_dims_ (s
);
9442 if (typeinit
== NULL_TREE
)
9444 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9445 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9446 int tc
= ffecom_f2c_typecode (bt
, kt
);
9449 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9452 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9454 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9456 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9458 TREE_CHAIN (TREE_CHAIN (varinits
))
9459 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9460 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9461 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9463 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9464 TREE_CONSTANT (varinits
) = 1;
9465 TREE_STATIC (varinits
) = 1;
9467 finish_decl (var
, varinits
, FALSE
);
9469 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9471 ffesymbol_hook (s
).vardesc_tree
= var
;
9474 return ffesymbol_hook (s
).vardesc_tree
;
9478 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9480 ffecom_vardesc_array_ (ffesymbol s
)
9484 tree item
= NULL_TREE
;
9487 static int mynumber
= 0;
9489 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9491 b
= ffebld_trail (b
), ++i
)
9495 t
= ffecom_vardesc_ (ffebld_head (b
));
9497 if (list
== NULL_TREE
)
9498 list
= item
= build_tree_list (NULL_TREE
, t
);
9501 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9502 item
= TREE_CHAIN (item
);
9506 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9507 build_range_type (integer_type_node
,
9509 build_int_2 (i
, 0)));
9510 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9511 TREE_CONSTANT (list
) = 1;
9512 TREE_STATIC (list
) = 1;
9514 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9515 var
= build_decl (VAR_DECL
, var
, item
);
9516 TREE_STATIC (var
) = 1;
9517 DECL_INITIAL (var
) = error_mark_node
;
9518 var
= start_decl (var
, FALSE
);
9519 finish_decl (var
, list
, FALSE
);
9525 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9527 ffecom_vardesc_dims_ (ffesymbol s
)
9529 if (ffesymbol_dims (s
) == NULL
)
9530 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9538 tree item
= NULL_TREE
;
9542 tree baseoff
= NULL_TREE
;
9543 static int mynumber
= 0;
9545 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9546 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9548 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9549 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9552 backlist
= NULL_TREE
;
9553 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9555 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9561 if (ffebld_trail (b
) == NULL
)
9565 t
= convert (ffecom_f2c_ftnlen_type_node
,
9566 ffecom_expr (ffebld_head (e
)));
9568 if (list
== NULL_TREE
)
9569 list
= item
= build_tree_list (NULL_TREE
, t
);
9572 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9573 item
= TREE_CHAIN (item
);
9577 if (ffebld_left (ffebld_head (b
)) == NULL
)
9578 low
= ffecom_integer_one_node
;
9580 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9581 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9583 back
= build_tree_list (low
, t
);
9584 TREE_CHAIN (back
) = backlist
;
9588 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9590 if (TREE_VALUE (item
) == NULL_TREE
)
9591 baseoff
= TREE_PURPOSE (item
);
9593 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9594 TREE_PURPOSE (item
),
9595 ffecom_2 (MULT_EXPR
,
9596 ffecom_f2c_ftnlen_type_node
,
9601 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9603 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9604 TREE_CHAIN (baseoff
) = list
;
9606 numelem
= build_tree_list (NULL_TREE
, numelem
);
9607 TREE_CHAIN (numelem
) = baseoff
;
9609 numdim
= build_tree_list (NULL_TREE
, numdim
);
9610 TREE_CHAIN (numdim
) = numelem
;
9612 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9613 build_range_type (integer_type_node
,
9616 ((int) ffesymbol_rank (s
)
9618 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9619 TREE_CONSTANT (list
) = 1;
9620 TREE_STATIC (list
) = 1;
9622 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9623 var
= build_decl (VAR_DECL
, var
, item
);
9624 TREE_STATIC (var
) = 1;
9625 DECL_INITIAL (var
) = error_mark_node
;
9626 var
= start_decl (var
, FALSE
);
9627 finish_decl (var
, list
, FALSE
);
9629 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9636 /* Essentially does a "fold (build1 (code, type, node))" while checking
9637 for certain housekeeping things.
9639 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9640 ffecom_1_fn instead. */
9642 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9644 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9648 if ((node
== error_mark_node
)
9649 || (type
== error_mark_node
))
9650 return error_mark_node
;
9652 if (code
== ADDR_EXPR
)
9654 if (!mark_addressable (node
))
9655 assert ("can't mark_addressable this node!" == NULL
);
9658 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9663 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9667 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9672 if (TREE_CODE (type
) != RECORD_TYPE
)
9674 item
= build1 (code
, type
, node
);
9677 node
= ffecom_stabilize_aggregate_ (node
);
9678 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9680 ffecom_2 (COMPLEX_EXPR
, type
,
9681 ffecom_1 (NEGATE_EXPR
, realtype
,
9682 ffecom_1 (REALPART_EXPR
, realtype
,
9684 ffecom_1 (NEGATE_EXPR
, realtype
,
9685 ffecom_1 (IMAGPART_EXPR
, realtype
,
9690 item
= build1 (code
, type
, node
);
9694 if (TREE_SIDE_EFFECTS (node
))
9695 TREE_SIDE_EFFECTS (item
) = 1;
9696 if ((code
== ADDR_EXPR
) && staticp (node
))
9697 TREE_CONSTANT (item
) = 1;
9702 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9703 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9704 does not set TREE_ADDRESSABLE (because calling an inline
9705 function does not mean the function needs to be separately
9708 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9710 ffecom_1_fn (tree node
)
9715 if (node
== error_mark_node
)
9716 return error_mark_node
;
9718 type
= build_type_variant (TREE_TYPE (node
),
9719 TREE_READONLY (node
),
9720 TREE_THIS_VOLATILE (node
));
9721 item
= build1 (ADDR_EXPR
,
9722 build_pointer_type (type
), node
);
9723 if (TREE_SIDE_EFFECTS (node
))
9724 TREE_SIDE_EFFECTS (item
) = 1;
9726 TREE_CONSTANT (item
) = 1;
9731 /* Essentially does a "fold (build (code, type, node1, node2))" while
9732 checking for certain housekeeping things. */
9734 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9736 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9741 if ((node1
== error_mark_node
)
9742 || (node2
== error_mark_node
)
9743 || (type
== error_mark_node
))
9744 return error_mark_node
;
9746 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9748 tree a
, b
, c
, d
, realtype
;
9751 assert ("no CONJ_EXPR support yet" == NULL
);
9752 return error_mark_node
;
9755 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9756 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9757 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9761 if (TREE_CODE (type
) != RECORD_TYPE
)
9763 item
= build (code
, type
, node1
, node2
);
9766 node1
= ffecom_stabilize_aggregate_ (node1
);
9767 node2
= ffecom_stabilize_aggregate_ (node2
);
9768 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9770 ffecom_2 (COMPLEX_EXPR
, type
,
9771 ffecom_2 (PLUS_EXPR
, realtype
,
9772 ffecom_1 (REALPART_EXPR
, realtype
,
9774 ffecom_1 (REALPART_EXPR
, realtype
,
9776 ffecom_2 (PLUS_EXPR
, realtype
,
9777 ffecom_1 (IMAGPART_EXPR
, realtype
,
9779 ffecom_1 (IMAGPART_EXPR
, realtype
,
9784 if (TREE_CODE (type
) != RECORD_TYPE
)
9786 item
= build (code
, type
, node1
, node2
);
9789 node1
= ffecom_stabilize_aggregate_ (node1
);
9790 node2
= ffecom_stabilize_aggregate_ (node2
);
9791 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9793 ffecom_2 (COMPLEX_EXPR
, type
,
9794 ffecom_2 (MINUS_EXPR
, realtype
,
9795 ffecom_1 (REALPART_EXPR
, realtype
,
9797 ffecom_1 (REALPART_EXPR
, realtype
,
9799 ffecom_2 (MINUS_EXPR
, realtype
,
9800 ffecom_1 (IMAGPART_EXPR
, realtype
,
9802 ffecom_1 (IMAGPART_EXPR
, realtype
,
9807 if (TREE_CODE (type
) != RECORD_TYPE
)
9809 item
= build (code
, type
, node1
, node2
);
9812 node1
= ffecom_stabilize_aggregate_ (node1
);
9813 node2
= ffecom_stabilize_aggregate_ (node2
);
9814 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9815 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9817 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9819 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9821 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9824 ffecom_2 (COMPLEX_EXPR
, type
,
9825 ffecom_2 (MINUS_EXPR
, realtype
,
9826 ffecom_2 (MULT_EXPR
, realtype
,
9829 ffecom_2 (MULT_EXPR
, realtype
,
9832 ffecom_2 (PLUS_EXPR
, realtype
,
9833 ffecom_2 (MULT_EXPR
, realtype
,
9836 ffecom_2 (MULT_EXPR
, realtype
,
9842 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9843 && (TREE_CODE (node2
) != RECORD_TYPE
))
9845 item
= build (code
, type
, node1
, node2
);
9848 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9849 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9850 node1
= ffecom_stabilize_aggregate_ (node1
);
9851 node2
= ffecom_stabilize_aggregate_ (node2
);
9852 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9854 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9855 ffecom_2 (code
, type
,
9856 ffecom_1 (REALPART_EXPR
, realtype
,
9858 ffecom_1 (REALPART_EXPR
, realtype
,
9860 ffecom_2 (code
, type
,
9861 ffecom_1 (IMAGPART_EXPR
, realtype
,
9863 ffecom_1 (IMAGPART_EXPR
, realtype
,
9868 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9869 && (TREE_CODE (node2
) != RECORD_TYPE
))
9871 item
= build (code
, type
, node1
, node2
);
9874 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9875 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9876 node1
= ffecom_stabilize_aggregate_ (node1
);
9877 node2
= ffecom_stabilize_aggregate_ (node2
);
9878 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9880 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9881 ffecom_2 (code
, type
,
9882 ffecom_1 (REALPART_EXPR
, realtype
,
9884 ffecom_1 (REALPART_EXPR
, realtype
,
9886 ffecom_2 (code
, type
,
9887 ffecom_1 (IMAGPART_EXPR
, realtype
,
9889 ffecom_1 (IMAGPART_EXPR
, realtype
,
9894 item
= build (code
, type
, node1
, node2
);
9898 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9899 TREE_SIDE_EFFECTS (item
) = 1;
9904 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9906 ffesymbol s; // the ENTRY point itself
9907 if (ffecom_2pass_advise_entrypoint(s))
9908 // the ENTRY point has been accepted
9910 Does whatever compiler needs to do when it learns about the entrypoint,
9911 like determine the return type of the master function, count the
9912 number of entrypoints, etc. Returns FALSE if the return type is
9913 not compatible with the return type(s) of other entrypoint(s).
9915 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9916 later (after _finish_progunit) be called with the same entrypoint(s)
9917 as passed to this fn for which TRUE was returned.
9920 Return FALSE if the return type conflicts with previous entrypoints. */
9922 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9924 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9926 ffebld list
; /* opITEM. */
9927 ffebld mlist
; /* opITEM. */
9928 ffebld plist
; /* opITEM. */
9929 ffebld arg
; /* ffebld_head(opITEM). */
9930 ffebld item
; /* opITEM. */
9931 ffesymbol s
; /* ffebld_symter(arg). */
9932 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9933 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9934 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9937 if (ffecom_num_entrypoints_
== 0)
9938 { /* First entrypoint, make list of main
9939 arglist's dummies. */
9940 assert (ffecom_primary_entry_
!= NULL
);
9942 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9943 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9944 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9946 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9948 list
= ffebld_trail (list
))
9950 arg
= ffebld_head (list
);
9951 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9952 continue; /* Alternate return or some such thing. */
9953 item
= ffebld_new_item (arg
, NULL
);
9955 ffecom_master_arglist_
= item
;
9957 ffebld_set_trail (plist
, item
);
9962 /* If necessary, scan entry arglist for alternate returns. Do this scan
9963 apparently redundantly (it's done below to UNIONize the arglists) so
9964 that we don't complain about RETURN 1 if an offending ENTRY is the only
9965 one with an alternate return. */
9967 if (!ffecom_is_altreturning_
)
9969 for (list
= ffesymbol_dummyargs (entry
);
9971 list
= ffebld_trail (list
))
9973 arg
= ffebld_head (list
);
9974 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9976 ffecom_is_altreturning_
= TRUE
;
9982 /* Now check type compatibility. */
9984 switch (ffecom_master_bt_
)
9986 case FFEINFO_basictypeNONE
:
9987 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
9990 case FFEINFO_basictypeCHARACTER
:
9992 = (bt
== FFEINFO_basictypeCHARACTER
)
9993 && (kt
== ffecom_master_kt_
)
9994 && (size
== ffecom_master_size_
);
9997 case FFEINFO_basictypeANY
:
9998 return FALSE
; /* Just don't bother. */
10001 if (bt
== FFEINFO_basictypeCHARACTER
)
10007 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10009 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10010 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10017 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10018 ffest_ffebad_here_current_stmt (0);
10020 return FALSE
; /* Can't handle entrypoint. */
10023 /* Entrypoint type compatible with previous types. */
10025 ++ffecom_num_entrypoints_
;
10027 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10029 for (list
= ffesymbol_dummyargs (entry
);
10031 list
= ffebld_trail (list
))
10033 arg
= ffebld_head (list
);
10034 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10035 continue; /* Alternate return or some such thing. */
10036 s
= ffebld_symter (arg
);
10037 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10039 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10040 { /* plist points to previous item for easy
10041 appending of arg. */
10042 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10043 break; /* Already have this arg in the master list. */
10046 continue; /* Already have this arg in the master list. */
10048 /* Append this arg to the master list. */
10050 item
= ffebld_new_item (arg
, NULL
);
10052 ffecom_master_arglist_
= item
;
10054 ffebld_set_trail (plist
, item
);
10061 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10063 ffesymbol s; // the ENTRY point itself
10064 ffecom_2pass_do_entrypoint(s);
10066 Does whatever compiler needs to do to make the entrypoint actually
10067 happen. Must be called for each entrypoint after
10068 ffecom_finish_progunit is called. */
10070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10072 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10074 static int mfn_num
= 0;
10075 static int ent_num
;
10077 if (mfn_num
!= ffecom_num_fns_
)
10078 { /* First entrypoint for this program unit. */
10080 mfn_num
= ffecom_num_fns_
;
10081 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10086 --ffecom_num_entrypoints_
;
10088 ffecom_do_entry_ (entry
, ent_num
);
10093 /* Essentially does a "fold (build (code, type, node1, node2))" while
10094 checking for certain housekeeping things. Always sets
10095 TREE_SIDE_EFFECTS. */
10097 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10099 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10104 if ((node1
== error_mark_node
)
10105 || (node2
== error_mark_node
)
10106 || (type
== error_mark_node
))
10107 return error_mark_node
;
10109 item
= build (code
, type
, node1
, node2
);
10110 TREE_SIDE_EFFECTS (item
) = 1;
10111 return fold (item
);
10115 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10116 checking for certain housekeeping things. */
10118 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10120 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10121 tree node2
, tree node3
)
10125 if ((node1
== error_mark_node
)
10126 || (node2
== error_mark_node
)
10127 || (node3
== error_mark_node
)
10128 || (type
== error_mark_node
))
10129 return error_mark_node
;
10131 item
= build (code
, type
, node1
, node2
, node3
);
10132 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10133 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10134 TREE_SIDE_EFFECTS (item
) = 1;
10135 return fold (item
);
10139 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10140 checking for certain housekeeping things. Always sets
10141 TREE_SIDE_EFFECTS. */
10143 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10145 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10146 tree node2
, tree node3
)
10150 if ((node1
== error_mark_node
)
10151 || (node2
== error_mark_node
)
10152 || (node3
== error_mark_node
)
10153 || (type
== error_mark_node
))
10154 return error_mark_node
;
10156 item
= build (code
, type
, node1
, node2
, node3
);
10157 TREE_SIDE_EFFECTS (item
) = 1;
10158 return fold (item
);
10163 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10165 See use by ffecom_list_expr.
10167 If expression is NULL, returns an integer zero tree. If it is not
10168 a CHARACTER expression, returns whatever ffecom_expr
10169 returns and sets the length return value to NULL_TREE. Otherwise
10170 generates code to evaluate the character expression, returns the proper
10171 pointer to the result, but does NOT set the length return value to a tree
10172 that specifies the length of the result. (In other words, the length
10173 variable is always set to NULL_TREE, because a length is never passed.)
10176 Don't set returned length, since nobody needs it (yet; someday if
10177 we allow CHARACTER*(*) dummies to statement functions, we'll need
10180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10182 ffecom_arg_expr (ffebld expr
, tree
*length
)
10186 *length
= NULL_TREE
;
10189 return integer_zero_node
;
10191 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10192 return ffecom_expr (expr
);
10194 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10198 /* Transform expression into constant argument-pointer-to-expression tree.
10200 If the expression can be transformed into a argument-pointer-to-expression
10201 tree that is constant, that is done, and the tree returned. Else
10202 NULL_TREE is returned.
10204 That way, a caller can attempt to provide compile-time initialization
10205 of a variable and, if that fails, *then* choose to start a new block
10206 and resort to using temporaries, as appropriate. */
10209 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10212 return integer_zero_node
;
10214 if (ffebld_op (expr
) == FFEBLD_opANY
)
10217 *length
= error_mark_node
;
10218 return error_mark_node
;
10221 if (ffebld_arity (expr
) == 0
10222 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10223 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10224 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10225 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10229 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10230 assert (TREE_CONSTANT (t
));
10231 assert (! length
|| TREE_CONSTANT (*length
));
10236 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10237 *length
= build_int_2 (ffebld_size (expr
), 0);
10239 *length
= NULL_TREE
;
10243 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10245 See use by ffecom_list_ptr_to_expr.
10247 If expression is NULL, returns an integer zero tree. If it is not
10248 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10249 returns and sets the length return value to NULL_TREE. Otherwise
10250 generates code to evaluate the character expression, returns the proper
10251 pointer to the result, AND sets the length return value to a tree that
10252 specifies the length of the result.
10254 If the length argument is NULL, this is a slightly special
10255 case of building a FORMAT expression, that is, an expression that
10256 will be used at run time without regard to length. For the current
10257 implementation, which uses the libf2c library, this means it is nice
10258 to append a null byte to the end of the expression, where feasible,
10259 to make sure any diagnostic about the FORMAT string terminates at
10262 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10263 length argument. This might even be seen as a feature, if a null
10264 byte can always be appended. */
10266 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10268 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10272 ffecomConcatList_ catlist
;
10274 if (length
!= NULL
)
10275 *length
= NULL_TREE
;
10278 return integer_zero_node
;
10280 switch (ffebld_op (expr
))
10282 case FFEBLD_opPERCENT_VAL
:
10283 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10284 return ffecom_expr (ffebld_left (expr
));
10289 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10290 if (temp_exp
== error_mark_node
)
10291 return error_mark_node
;
10293 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10297 case FFEBLD_opPERCENT_REF
:
10298 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10299 return ffecom_ptr_to_expr (ffebld_left (expr
));
10300 if (length
!= NULL
)
10302 ign_length
= NULL_TREE
;
10303 length
= &ign_length
;
10305 expr
= ffebld_left (expr
);
10308 case FFEBLD_opPERCENT_DESCR
:
10309 switch (ffeinfo_basictype (ffebld_info (expr
)))
10311 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10312 case FFEINFO_basictypeHOLLERITH
:
10314 case FFEINFO_basictypeCHARACTER
:
10315 break; /* Passed by descriptor anyway. */
10318 item
= ffecom_ptr_to_expr (expr
);
10319 if (item
!= error_mark_node
)
10320 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10329 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10330 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10331 && (length
!= NULL
))
10332 { /* Pass Hollerith by descriptor. */
10333 ffetargetHollerith h
;
10335 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10336 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10337 (ffebld_conter (expr
)));
10339 = build_int_2 (h
.length
, 0);
10340 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10344 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10345 return ffecom_ptr_to_expr (expr
);
10347 assert (ffeinfo_kindtype (ffebld_info (expr
))
10348 == FFEINFO_kindtypeCHARACTER1
);
10350 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10351 expr
= ffebld_left (expr
);
10353 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10354 switch (ffecom_concat_list_count_ (catlist
))
10356 case 0: /* Shouldn't happen, but in case it does... */
10357 if (length
!= NULL
)
10359 *length
= ffecom_f2c_ftnlen_zero_node
;
10360 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10362 ffecom_concat_list_kill_ (catlist
);
10363 return null_pointer_node
;
10365 case 1: /* The (fairly) easy case. */
10366 if (length
== NULL
)
10367 ffecom_char_args_with_null_ (&item
, &ign_length
,
10368 ffecom_concat_list_expr_ (catlist
, 0));
10370 ffecom_char_args_ (&item
, length
,
10371 ffecom_concat_list_expr_ (catlist
, 0));
10372 ffecom_concat_list_kill_ (catlist
);
10373 assert (item
!= NULL_TREE
);
10376 default: /* Must actually concatenate things. */
10381 int count
= ffecom_concat_list_count_ (catlist
);
10392 ffetargetCharacterSize sz
;
10394 sz
= ffecom_concat_list_maxlen_ (catlist
);
10396 assert (sz
!= FFETARGET_charactersizeNONE
);
10401 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10402 FFETARGET_charactersizeNONE
, count
, TRUE
);
10405 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10406 FFETARGET_charactersizeNONE
, count
, TRUE
);
10407 temporary
= ffecom_push_tempvar (char_type_node
,
10413 hook
= ffebld_nonter_hook (expr
);
10415 assert (TREE_CODE (hook
) == TREE_VEC
);
10416 assert (TREE_VEC_LENGTH (hook
) == 3);
10417 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10418 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10419 temporary
= TREE_VEC_ELT (hook
, 2);
10423 known_length
= ffecom_f2c_ftnlen_zero_node
;
10425 for (i
= 0; i
< count
; ++i
)
10428 && (length
== NULL
))
10429 ffecom_char_args_with_null_ (&citem
, &clength
,
10430 ffecom_concat_list_expr_ (catlist
, i
));
10432 ffecom_char_args_ (&citem
, &clength
,
10433 ffecom_concat_list_expr_ (catlist
, i
));
10434 if ((citem
== error_mark_node
)
10435 || (clength
== error_mark_node
))
10437 ffecom_concat_list_kill_ (catlist
);
10438 *length
= error_mark_node
;
10439 return error_mark_node
;
10443 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10444 ffecom_modify (void_type_node
,
10445 ffecom_2 (ARRAY_REF
,
10446 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10448 build_int_2 (i
, 0)),
10451 clength
= ffecom_save_tree (clength
);
10452 if (length
!= NULL
)
10454 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10458 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10459 ffecom_modify (void_type_node
,
10460 ffecom_2 (ARRAY_REF
,
10461 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10463 build_int_2 (i
, 0)),
10468 temporary
= ffecom_1 (ADDR_EXPR
,
10469 build_pointer_type (TREE_TYPE (temporary
)),
10472 item
= build_tree_list (NULL_TREE
, temporary
);
10474 = build_tree_list (NULL_TREE
,
10475 ffecom_1 (ADDR_EXPR
,
10476 build_pointer_type (TREE_TYPE (items
)),
10478 TREE_CHAIN (TREE_CHAIN (item
))
10479 = build_tree_list (NULL_TREE
,
10480 ffecom_1 (ADDR_EXPR
,
10481 build_pointer_type (TREE_TYPE (lengths
)),
10483 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10486 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10487 convert (ffecom_f2c_ftnlen_type_node
,
10488 build_int_2 (count
, 0))));
10489 num
= build_int_2 (sz
, 0);
10490 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10491 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10492 = build_tree_list (NULL_TREE
, num
);
10494 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10495 TREE_SIDE_EFFECTS (item
) = 1;
10496 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10500 if (length
!= NULL
)
10501 *length
= known_length
;
10504 ffecom_concat_list_kill_ (catlist
);
10505 assert (item
!= NULL_TREE
);
10510 /* Generate call to run-time function.
10512 The first arg is the GNU Fortran Run-Time function index, the second
10513 arg is the list of arguments to pass to it. Returned is the expression
10514 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10515 result (which may be void). */
10517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10519 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10521 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10522 ffecom_gfrt_kindtype (ix
),
10523 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10524 NULL_TREE
, args
, NULL_TREE
, NULL
,
10525 NULL
, NULL_TREE
, TRUE
, hook
);
10529 /* Transform constant-union to tree. */
10531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10533 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10534 ffeinfoKindtype kt
, tree tree_type
)
10540 case FFEINFO_basictypeINTEGER
:
10546 #if FFETARGET_okINTEGER1
10547 case FFEINFO_kindtypeINTEGER1
:
10548 val
= ffebld_cu_val_integer1 (*cu
);
10552 #if FFETARGET_okINTEGER2
10553 case FFEINFO_kindtypeINTEGER2
:
10554 val
= ffebld_cu_val_integer2 (*cu
);
10558 #if FFETARGET_okINTEGER3
10559 case FFEINFO_kindtypeINTEGER3
:
10560 val
= ffebld_cu_val_integer3 (*cu
);
10564 #if FFETARGET_okINTEGER4
10565 case FFEINFO_kindtypeINTEGER4
:
10566 val
= ffebld_cu_val_integer4 (*cu
);
10571 assert ("bad INTEGER constant kind type" == NULL
);
10572 /* Fall through. */
10573 case FFEINFO_kindtypeANY
:
10574 return error_mark_node
;
10576 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10577 TREE_TYPE (item
) = tree_type
;
10581 case FFEINFO_basictypeLOGICAL
:
10587 #if FFETARGET_okLOGICAL1
10588 case FFEINFO_kindtypeLOGICAL1
:
10589 val
= ffebld_cu_val_logical1 (*cu
);
10593 #if FFETARGET_okLOGICAL2
10594 case FFEINFO_kindtypeLOGICAL2
:
10595 val
= ffebld_cu_val_logical2 (*cu
);
10599 #if FFETARGET_okLOGICAL3
10600 case FFEINFO_kindtypeLOGICAL3
:
10601 val
= ffebld_cu_val_logical3 (*cu
);
10605 #if FFETARGET_okLOGICAL4
10606 case FFEINFO_kindtypeLOGICAL4
:
10607 val
= ffebld_cu_val_logical4 (*cu
);
10612 assert ("bad LOGICAL constant kind type" == NULL
);
10613 /* Fall through. */
10614 case FFEINFO_kindtypeANY
:
10615 return error_mark_node
;
10617 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10618 TREE_TYPE (item
) = tree_type
;
10622 case FFEINFO_basictypeREAL
:
10624 REAL_VALUE_TYPE val
;
10628 #if FFETARGET_okREAL1
10629 case FFEINFO_kindtypeREAL1
:
10630 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10634 #if FFETARGET_okREAL2
10635 case FFEINFO_kindtypeREAL2
:
10636 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10640 #if FFETARGET_okREAL3
10641 case FFEINFO_kindtypeREAL3
:
10642 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10646 #if FFETARGET_okREAL4
10647 case FFEINFO_kindtypeREAL4
:
10648 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10653 assert ("bad REAL constant kind type" == NULL
);
10654 /* Fall through. */
10655 case FFEINFO_kindtypeANY
:
10656 return error_mark_node
;
10658 item
= build_real (tree_type
, val
);
10662 case FFEINFO_basictypeCOMPLEX
:
10664 REAL_VALUE_TYPE real
;
10665 REAL_VALUE_TYPE imag
;
10666 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10670 #if FFETARGET_okCOMPLEX1
10671 case FFEINFO_kindtypeREAL1
:
10672 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10673 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10677 #if FFETARGET_okCOMPLEX2
10678 case FFEINFO_kindtypeREAL2
:
10679 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10680 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10684 #if FFETARGET_okCOMPLEX3
10685 case FFEINFO_kindtypeREAL3
:
10686 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10687 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10691 #if FFETARGET_okCOMPLEX4
10692 case FFEINFO_kindtypeREAL4
:
10693 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10694 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10699 assert ("bad REAL constant kind type" == NULL
);
10700 /* Fall through. */
10701 case FFEINFO_kindtypeANY
:
10702 return error_mark_node
;
10704 item
= ffecom_build_complex_constant_ (tree_type
,
10705 build_real (el_type
, real
),
10706 build_real (el_type
, imag
));
10710 case FFEINFO_basictypeCHARACTER
:
10711 { /* Happens only in DATA and similar contexts. */
10712 ffetargetCharacter1 val
;
10716 #if FFETARGET_okCHARACTER1
10717 case FFEINFO_kindtypeLOGICAL1
:
10718 val
= ffebld_cu_val_character1 (*cu
);
10723 assert ("bad CHARACTER constant kind type" == NULL
);
10724 /* Fall through. */
10725 case FFEINFO_kindtypeANY
:
10726 return error_mark_node
;
10728 item
= build_string (ffetarget_length_character1 (val
),
10729 ffetarget_text_character1 (val
));
10731 = build_type_variant (build_array_type (char_type_node
,
10733 (integer_type_node
,
10736 (ffetarget_length_character1
10742 case FFEINFO_basictypeHOLLERITH
:
10744 ffetargetHollerith h
;
10746 h
= ffebld_cu_val_hollerith (*cu
);
10748 /* If not at least as wide as default INTEGER, widen it. */
10749 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10750 item
= build_string (h
.length
, h
.text
);
10753 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10755 memcpy (str
, h
.text
, h
.length
);
10756 memset (&str
[h
.length
], ' ',
10757 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10759 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10763 = build_type_variant (build_array_type (char_type_node
,
10765 (integer_type_node
,
10773 case FFEINFO_basictypeTYPELESS
:
10775 ffetargetInteger1 ival
;
10776 ffetargetTypeless tless
;
10779 tless
= ffebld_cu_val_typeless (*cu
);
10780 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10781 assert (error
== FFEBAD
);
10783 item
= build_int_2 ((int) ival
, 0);
10788 assert ("not yet on constant type" == NULL
);
10789 /* Fall through. */
10790 case FFEINFO_basictypeANY
:
10791 return error_mark_node
;
10794 TREE_CONSTANT (item
) = 1;
10801 /* Transform expression into constant tree.
10803 If the expression can be transformed into a tree that is constant,
10804 that is done, and the tree returned. Else NULL_TREE is returned.
10806 That way, a caller can attempt to provide compile-time initialization
10807 of a variable and, if that fails, *then* choose to start a new block
10808 and resort to using temporaries, as appropriate. */
10811 ffecom_const_expr (ffebld expr
)
10814 return integer_zero_node
;
10816 if (ffebld_op (expr
) == FFEBLD_opANY
)
10817 return error_mark_node
;
10819 if (ffebld_arity (expr
) == 0
10820 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10822 /* ~~Enable once common/equivalence is handled properly? */
10823 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10825 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10826 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10830 t
= ffecom_expr (expr
);
10831 assert (TREE_CONSTANT (t
));
10838 /* Handy way to make a field in a struct/union. */
10840 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10842 ffecom_decl_field (tree context
, tree prevfield
,
10843 const char *name
, tree type
)
10847 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10848 DECL_CONTEXT (field
) = context
;
10849 DECL_ALIGN (field
) = 0;
10850 DECL_USER_ALIGN (field
) = 0;
10851 if (prevfield
!= NULL_TREE
)
10852 TREE_CHAIN (prevfield
) = field
;
10860 ffecom_close_include (FILE *f
)
10862 #if FFECOM_GCC_INCLUDE
10863 ffecom_close_include_ (f
);
10868 ffecom_decode_include_option (char *spec
)
10870 #if FFECOM_GCC_INCLUDE
10871 return ffecom_decode_include_option_ (spec
);
10877 /* End a compound statement (block). */
10879 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10881 ffecom_end_compstmt (void)
10883 return bison_rule_compstmt_ ();
10885 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10887 /* ffecom_end_transition -- Perform end transition on all symbols
10889 ffecom_end_transition();
10891 Calls ffecom_sym_end_transition for each global and local symbol. */
10894 ffecom_end_transition ()
10896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10900 if (ffe_is_ffedebug ())
10901 fprintf (dmpout
, "; end_stmt_transition\n");
10903 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10904 ffecom_list_blockdata_
= NULL
;
10905 ffecom_list_common_
= NULL
;
10908 ffesymbol_drive (ffecom_sym_end_transition
);
10909 if (ffe_is_ffedebug ())
10911 ffestorag_report ();
10912 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10913 ffesymbol_report_all ();
10917 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10918 ffecom_start_progunit_ ();
10920 for (item
= ffecom_list_blockdata_
;
10922 item
= ffebld_trail (item
))
10929 static int number
= 0;
10931 callee
= ffebld_head (item
);
10932 s
= ffebld_symter (callee
);
10933 t
= ffesymbol_hook (s
).decl_tree
;
10934 if (t
== NULL_TREE
)
10936 s
= ffecom_sym_transform_ (s
);
10937 t
= ffesymbol_hook (s
).decl_tree
;
10940 dt
= build_pointer_type (TREE_TYPE (t
));
10942 var
= build_decl (VAR_DECL
,
10943 ffecom_get_invented_identifier ("__g77_forceload_%d",
10946 DECL_EXTERNAL (var
) = 0;
10947 TREE_STATIC (var
) = 1;
10948 TREE_PUBLIC (var
) = 0;
10949 DECL_INITIAL (var
) = error_mark_node
;
10950 TREE_USED (var
) = 1;
10952 var
= start_decl (var
, FALSE
);
10954 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10956 finish_decl (var
, t
, FALSE
);
10959 /* This handles any COMMON areas that weren't referenced but have, for
10960 example, important initial data. */
10962 for (item
= ffecom_list_common_
;
10964 item
= ffebld_trail (item
))
10965 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10967 ffecom_list_common_
= NULL
;
10971 /* ffecom_exec_transition -- Perform exec transition on all symbols
10973 ffecom_exec_transition();
10975 Calls ffecom_sym_exec_transition for each global and local symbol.
10976 Make sure error updating not inhibited. */
10979 ffecom_exec_transition ()
10983 if (ffe_is_ffedebug ())
10984 fprintf (dmpout
, "; exec_stmt_transition\n");
10986 inhibited
= ffebad_inhibit ();
10987 ffebad_set_inhibit (FALSE
);
10989 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
10990 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10991 if (ffe_is_ffedebug ())
10993 ffestorag_report ();
10994 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10995 ffesymbol_report_all ();
11000 ffebad_set_inhibit (TRUE
);
11003 /* Handle assignment statement.
11005 Convert dest and source using ffecom_expr, then join them
11006 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11008 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11010 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11017 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11022 /* This attempts to replicate the test below, but must not be
11023 true when the test below is false. (Always err on the side
11024 of creating unused temporaries, to avoid ICEs.) */
11025 if (ffebld_op (dest
) != FFEBLD_opSYMTER
11026 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
11027 && (TREE_CODE (dest_tree
) != VAR_DECL
11028 || TREE_ADDRESSABLE (dest_tree
))))
11030 ffecom_prepare_expr_ (source
, dest
);
11035 ffecom_prepare_expr_ (source
, NULL
);
11039 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11041 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11042 create a temporary through which the assignment is to take place,
11043 since MODIFY_EXPR doesn't handle partial overlap properly. */
11044 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
11045 && ffecom_possible_partial_overlap_ (dest
, source
))
11047 assign_temp
= ffecom_make_tempvar ("complex_let",
11049 [ffebld_basictype (dest
)]
11050 [ffebld_kindtype (dest
)],
11051 FFETARGET_charactersizeNONE
,
11055 assign_temp
= NULL_TREE
;
11057 ffecom_prepare_end ();
11059 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
11060 if (dest_tree
== error_mark_node
)
11063 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11064 || TREE_ADDRESSABLE (dest_tree
))
11065 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
11069 assert (! dest_used
);
11071 source_tree
= ffecom_expr (source
);
11073 if (source_tree
== error_mark_node
)
11077 expr_tree
= source_tree
;
11078 else if (assign_temp
)
11081 /* The back end understands a conceptual move (evaluate source;
11082 store into dest), so use that, in case it can determine
11083 that it is going to use, say, two registers as temporaries
11084 anyway. So don't use the temp (and someday avoid generating
11085 it, once this code starts triggering regularly). */
11086 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
11090 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11093 expand_expr_stmt (expr_tree
);
11094 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11100 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11104 expand_expr_stmt (expr_tree
);
11108 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
11109 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11111 ffecom_prepare_end ();
11113 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11114 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11119 /* ffecom_expr -- Transform expr into gcc tree
11122 ffebld expr; // FFE expression.
11123 tree = ffecom_expr(expr);
11125 Recursive descent on expr while making corresponding tree nodes and
11126 attaching type info and such. */
11128 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11130 ffecom_expr (ffebld expr
)
11132 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
11136 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11138 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11140 ffecom_expr_assign (ffebld expr
)
11142 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11146 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11148 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11150 ffecom_expr_assign_w (ffebld expr
)
11152 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11156 /* Transform expr for use as into read/write tree and stabilize the
11157 reference. Not for use on CHARACTER expressions.
11159 Recursive descent on expr while making corresponding tree nodes and
11160 attaching type info and such. */
11162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11164 ffecom_expr_rw (tree type
, ffebld expr
)
11166 assert (expr
!= NULL
);
11167 /* Different target types not yet supported. */
11168 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11170 return stabilize_reference (ffecom_expr (expr
));
11174 /* Transform expr for use as into write tree and stabilize the
11175 reference. Not for use on CHARACTER expressions.
11177 Recursive descent on expr while making corresponding tree nodes and
11178 attaching type info and such. */
11180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11182 ffecom_expr_w (tree type
, ffebld expr
)
11184 assert (expr
!= NULL
);
11185 /* Different target types not yet supported. */
11186 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11188 return stabilize_reference (ffecom_expr (expr
));
11192 /* Do global stuff. */
11194 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11196 ffecom_finish_compile ()
11198 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11199 assert (current_function_decl
== NULL_TREE
);
11201 ffeglobal_drive (ffecom_finish_global_
);
11205 /* Public entry point for front end to access finish_decl. */
11207 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11209 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11211 assert (!is_top_level
);
11212 finish_decl (decl
, init
, FALSE
);
11216 /* Finish a program unit. */
11218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11220 ffecom_finish_progunit ()
11222 ffecom_end_compstmt ();
11224 ffecom_previous_function_decl_
= current_function_decl
;
11225 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11227 finish_function (0);
11232 /* Wrapper for get_identifier. pattern is sprintf-like. */
11234 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11236 ffecom_get_invented_identifier (const char *pattern
, ...)
11242 va_start (ap
, pattern
);
11243 if (vasprintf (&nam
, pattern
, ap
) == 0)
11246 decl
= get_identifier (nam
);
11248 IDENTIFIER_INVENTED (decl
) = 1;
11253 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11255 assert (gfrt
< FFECOM_gfrt
);
11257 switch (ffecom_gfrt_type_
[gfrt
])
11259 case FFECOM_rttypeVOID_
:
11260 case FFECOM_rttypeVOIDSTAR_
:
11261 return FFEINFO_basictypeNONE
;
11263 case FFECOM_rttypeFTNINT_
:
11264 return FFEINFO_basictypeINTEGER
;
11266 case FFECOM_rttypeINTEGER_
:
11267 return FFEINFO_basictypeINTEGER
;
11269 case FFECOM_rttypeLONGINT_
:
11270 return FFEINFO_basictypeINTEGER
;
11272 case FFECOM_rttypeLOGICAL_
:
11273 return FFEINFO_basictypeLOGICAL
;
11275 case FFECOM_rttypeREAL_F2C_
:
11276 case FFECOM_rttypeREAL_GNU_
:
11277 return FFEINFO_basictypeREAL
;
11279 case FFECOM_rttypeCOMPLEX_F2C_
:
11280 case FFECOM_rttypeCOMPLEX_GNU_
:
11281 return FFEINFO_basictypeCOMPLEX
;
11283 case FFECOM_rttypeDOUBLE_
:
11284 case FFECOM_rttypeDOUBLEREAL_
:
11285 return FFEINFO_basictypeREAL
;
11287 case FFECOM_rttypeDBLCMPLX_F2C_
:
11288 case FFECOM_rttypeDBLCMPLX_GNU_
:
11289 return FFEINFO_basictypeCOMPLEX
;
11291 case FFECOM_rttypeCHARACTER_
:
11292 return FFEINFO_basictypeCHARACTER
;
11295 return FFEINFO_basictypeANY
;
11300 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11302 assert (gfrt
< FFECOM_gfrt
);
11304 switch (ffecom_gfrt_type_
[gfrt
])
11306 case FFECOM_rttypeVOID_
:
11307 case FFECOM_rttypeVOIDSTAR_
:
11308 return FFEINFO_kindtypeNONE
;
11310 case FFECOM_rttypeFTNINT_
:
11311 return FFEINFO_kindtypeINTEGER1
;
11313 case FFECOM_rttypeINTEGER_
:
11314 return FFEINFO_kindtypeINTEGER1
;
11316 case FFECOM_rttypeLONGINT_
:
11317 return FFEINFO_kindtypeINTEGER4
;
11319 case FFECOM_rttypeLOGICAL_
:
11320 return FFEINFO_kindtypeLOGICAL1
;
11322 case FFECOM_rttypeREAL_F2C_
:
11323 case FFECOM_rttypeREAL_GNU_
:
11324 return FFEINFO_kindtypeREAL1
;
11326 case FFECOM_rttypeCOMPLEX_F2C_
:
11327 case FFECOM_rttypeCOMPLEX_GNU_
:
11328 return FFEINFO_kindtypeREAL1
;
11330 case FFECOM_rttypeDOUBLE_
:
11331 case FFECOM_rttypeDOUBLEREAL_
:
11332 return FFEINFO_kindtypeREAL2
;
11334 case FFECOM_rttypeDBLCMPLX_F2C_
:
11335 case FFECOM_rttypeDBLCMPLX_GNU_
:
11336 return FFEINFO_kindtypeREAL2
;
11338 case FFECOM_rttypeCHARACTER_
:
11339 return FFEINFO_kindtypeCHARACTER1
;
11342 return FFEINFO_kindtypeANY
;
11356 tree double_ftype_double
;
11357 tree float_ftype_float
;
11358 tree ldouble_ftype_ldouble
;
11359 tree ffecom_tree_ptr_to_fun_type_void
;
11361 /* This block of code comes from the now-obsolete cktyps.c. It checks
11362 whether the compiler environment is buggy in known ways, some of which
11363 would, if not explicitly checked here, result in subtle bugs in g77. */
11365 if (ffe_is_do_internal_checks ())
11367 static char names
[][12]
11369 {"bar", "bletch", "foo", "foobar"};
11374 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11375 (int (*)(const void *, const void *)) strcmp
);
11376 if (name
!= (char *) &names
[2])
11378 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11383 ul
= strtoul ("123456789", NULL
, 10);
11384 if (ul
!= 123456789L)
11386 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11387 in proj.h" == NULL
);
11391 fl
= atof ("56.789");
11392 if ((fl
< 56.788) || (fl
> 56.79))
11394 assert ("atof not type double, fix your #include <stdio.h>"
11400 #if FFECOM_GCC_INCLUDE
11401 ffecom_initialize_char_syntax_ ();
11404 ffecom_outer_function_decl_
= NULL_TREE
;
11405 current_function_decl
= NULL_TREE
;
11406 named_labels
= NULL_TREE
;
11407 current_binding_level
= NULL_BINDING_LEVEL
;
11408 free_binding_level
= NULL_BINDING_LEVEL
;
11409 /* Make the binding_level structure for global names. */
11411 global_binding_level
= current_binding_level
;
11412 current_binding_level
->prep_state
= 2;
11414 build_common_tree_nodes (1);
11416 /* Define `int' and `char' first so that dbx will output them first. */
11417 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11418 integer_type_node
));
11419 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11421 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11422 long_integer_type_node
));
11423 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11424 unsigned_type_node
));
11425 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11426 long_unsigned_type_node
));
11427 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11428 long_long_integer_type_node
));
11429 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11430 long_long_unsigned_type_node
));
11431 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11432 short_integer_type_node
));
11433 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11434 short_unsigned_type_node
));
11436 /* Set the sizetype before we make other types. This *should* be the
11437 first type we create. */
11440 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11441 ffecom_typesize_pointer_
11442 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11444 build_common_tree_nodes_2 (0);
11446 /* Define both `signed char' and `unsigned char'. */
11447 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11448 signed_char_type_node
));
11450 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11451 unsigned_char_type_node
));
11453 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11455 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11456 double_type_node
));
11457 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11458 long_double_type_node
));
11460 /* For now, override what build_common_tree_nodes has done. */
11461 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11462 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11463 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11464 complex_long_double_type_node
11465 = ffecom_make_complex_type_ (long_double_type_node
);
11467 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11468 complex_integer_type_node
));
11469 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11470 complex_float_type_node
));
11471 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11472 complex_double_type_node
));
11473 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11474 complex_long_double_type_node
));
11476 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11478 /* We are not going to have real types in C with less than byte alignment,
11479 so we might as well not have any types that claim to have it. */
11480 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11481 TYPE_USER_ALIGN (void_type_node
) = 0;
11483 string_type_node
= build_pointer_type (char_type_node
);
11485 ffecom_tree_fun_type_void
11486 = build_function_type (void_type_node
, NULL_TREE
);
11488 ffecom_tree_ptr_to_fun_type_void
11489 = build_pointer_type (ffecom_tree_fun_type_void
);
11491 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11494 = build_function_type (float_type_node
,
11495 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11497 double_ftype_double
11498 = build_function_type (double_type_node
,
11499 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11501 ldouble_ftype_ldouble
11502 = build_function_type (long_double_type_node
,
11503 tree_cons (NULL_TREE
, long_double_type_node
,
11506 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11507 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11509 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11510 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11511 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11512 ffecom_f2c_typecode_
[i
][j
] = -1;
11515 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11516 to size FLOAT_TYPE_SIZE because they have to be the same size as
11517 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11518 Compiler options and other such stuff that change the ways these
11519 types are set should not affect this particular setup. */
11521 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11522 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11523 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11525 type
= ffetype_new ();
11527 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11529 ffetype_set_ams (type
,
11530 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11531 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11532 ffetype_set_star (base_type
,
11533 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11535 ffetype_set_kind (base_type
, 1, type
);
11536 ffecom_typesize_integer1_
= ffetype_size (type
);
11537 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11539 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11540 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11541 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11544 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11545 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11546 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11548 type
= ffetype_new ();
11549 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
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
, 3, type
);
11558 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11560 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11561 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11562 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11565 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11566 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11567 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11569 type
= ffetype_new ();
11570 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11572 ffetype_set_ams (type
,
11573 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11574 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11575 ffetype_set_star (base_type
,
11576 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11578 ffetype_set_kind (base_type
, 6, type
);
11579 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11581 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11582 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11583 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11586 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11587 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11588 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11590 type
= ffetype_new ();
11591 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11593 ffetype_set_ams (type
,
11594 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11595 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11596 ffetype_set_star (base_type
,
11597 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11599 ffetype_set_kind (base_type
, 2, type
);
11600 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11602 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11603 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11604 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11608 if (ffe_is_do_internal_checks ()
11609 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11610 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11611 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11612 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11614 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11619 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11620 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11621 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11623 type
= ffetype_new ();
11625 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11627 ffetype_set_ams (type
,
11628 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11629 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11630 ffetype_set_star (base_type
,
11631 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11633 ffetype_set_kind (base_type
, 1, type
);
11634 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11636 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11637 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11638 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11640 type
= ffetype_new ();
11641 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11643 ffetype_set_ams (type
,
11644 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11645 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11646 ffetype_set_star (base_type
,
11647 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11649 ffetype_set_kind (base_type
, 3, type
);
11650 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11652 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11653 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11654 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11656 type
= ffetype_new ();
11657 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11659 ffetype_set_ams (type
,
11660 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11661 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11662 ffetype_set_star (base_type
,
11663 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11665 ffetype_set_kind (base_type
, 6, type
);
11666 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11668 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11669 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11670 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11672 type
= ffetype_new ();
11673 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11675 ffetype_set_ams (type
,
11676 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11677 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11678 ffetype_set_star (base_type
,
11679 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11681 ffetype_set_kind (base_type
, 2, type
);
11682 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11684 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11685 = t
= make_node (REAL_TYPE
);
11686 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11687 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11690 type
= ffetype_new ();
11692 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11694 ffetype_set_ams (type
,
11695 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11696 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11697 ffetype_set_star (base_type
,
11698 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11700 ffetype_set_kind (base_type
, 1, type
);
11701 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11702 = FFETARGET_f2cTYREAL
;
11703 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11705 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11706 = t
= make_node (REAL_TYPE
);
11707 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11708 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11711 type
= ffetype_new ();
11712 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11714 ffetype_set_ams (type
,
11715 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11716 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11717 ffetype_set_star (base_type
,
11718 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11720 ffetype_set_kind (base_type
, 2, type
);
11721 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11722 = FFETARGET_f2cTYDREAL
;
11723 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11725 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11726 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11727 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11729 type
= ffetype_new ();
11731 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11733 ffetype_set_ams (type
,
11734 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11735 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11736 ffetype_set_star (base_type
,
11737 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11739 ffetype_set_kind (base_type
, 1, type
);
11740 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11741 = FFETARGET_f2cTYCOMPLEX
;
11742 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11744 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11745 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11746 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11748 type
= ffetype_new ();
11749 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11751 ffetype_set_ams (type
,
11752 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11753 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11754 ffetype_set_star (base_type
,
11755 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11757 ffetype_set_kind (base_type
, 2,
11759 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11760 = FFETARGET_f2cTYDCOMPLEX
;
11761 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11763 /* Make function and ptr-to-function types for non-CHARACTER types. */
11765 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11766 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11768 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11770 if (i
== FFEINFO_basictypeINTEGER
)
11772 /* Figure out the smallest INTEGER type that can hold
11773 a pointer on this machine. */
11774 if (GET_MODE_SIZE (TYPE_MODE (t
))
11775 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11777 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11778 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11779 > GET_MODE_SIZE (TYPE_MODE (t
))))
11780 ffecom_pointer_kind_
= j
;
11783 else if (i
== FFEINFO_basictypeCOMPLEX
)
11784 t
= void_type_node
;
11785 /* For f2c compatibility, REAL functions are really
11786 implemented as DOUBLE PRECISION. */
11787 else if ((i
== FFEINFO_basictypeREAL
)
11788 && (j
== FFEINFO_kindtypeREAL1
))
11789 t
= ffecom_tree_type
11790 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11792 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11794 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11798 /* Set up pointer types. */
11800 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11801 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11802 else if (0 && ffe_is_do_internal_checks ())
11803 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11804 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11805 FFEINFO_kindtypeINTEGERDEFAULT
),
11807 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11808 ffecom_pointer_kind_
));
11810 if (ffe_is_ugly_assign ())
11811 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11813 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11814 if (0 && ffe_is_do_internal_checks ())
11815 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11817 ffecom_integer_type_node
11818 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11819 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11820 integer_zero_node
);
11821 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11824 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11825 Turns out that by TYLONG, runtime/libI77/lio.h really means
11826 "whatever size an ftnint is". For consistency and sanity,
11827 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11828 all are INTEGER, which we also make out of whatever back-end
11829 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11830 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11831 accommodate machines like the Alpha. Note that this suggests
11832 f2c and libf2c are missing a distinction perhaps needed on
11833 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11835 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11836 FFETARGET_f2cTYLONG
);
11837 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11838 FFETARGET_f2cTYSHORT
);
11839 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11840 FFETARGET_f2cTYINT1
);
11841 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11842 FFETARGET_f2cTYQUAD
);
11843 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11844 FFETARGET_f2cTYLOGICAL
);
11845 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11846 FFETARGET_f2cTYLOGICAL2
);
11847 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11848 FFETARGET_f2cTYLOGICAL1
);
11849 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11850 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11851 FFETARGET_f2cTYQUAD
);
11853 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11854 loop. CHARACTER items are built as arrays of unsigned char. */
11856 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11857 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11858 type
= ffetype_new ();
11860 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11861 FFEINFO_kindtypeCHARACTER1
,
11863 ffetype_set_ams (type
,
11864 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11865 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11866 ffetype_set_kind (base_type
, 1, type
);
11867 assert (ffetype_size (type
)
11868 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11870 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11871 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11872 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11873 [FFEINFO_kindtypeCHARACTER1
]
11874 = ffecom_tree_ptr_to_fun_type_void
;
11875 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11876 = FFETARGET_f2cTYCHAR
;
11878 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11881 /* Make multi-return-value type and fields. */
11883 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11887 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11888 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11892 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11893 continue; /* Not supported. */
11894 sprintf (&name
[0], "bt_%s_kt_%s",
11895 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11896 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11897 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11898 get_identifier (name
),
11899 ffecom_tree_type
[i
][j
]);
11900 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11901 = ffecom_multi_type_node_
;
11902 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11903 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11904 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11905 field
= ffecom_multi_fields_
[i
][j
];
11908 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11909 layout_type (ffecom_multi_type_node_
);
11911 /* Subroutines usually return integer because they might have alternate
11914 ffecom_tree_subr_type
11915 = build_function_type (integer_type_node
, NULL_TREE
);
11916 ffecom_tree_ptr_to_subr_type
11917 = build_pointer_type (ffecom_tree_subr_type
);
11918 ffecom_tree_blockdata_type
11919 = build_function_type (void_type_node
, NULL_TREE
);
11921 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11922 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtf");
11923 builtin_function ("__builtin_fsqrt", double_ftype_double
,
11924 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrt");
11925 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11926 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtl");
11927 builtin_function ("__builtin_sinf", float_ftype_float
,
11928 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinf");
11929 builtin_function ("__builtin_sin", double_ftype_double
,
11930 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin");
11931 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11932 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinl");
11933 builtin_function ("__builtin_cosf", float_ftype_float
,
11934 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosf");
11935 builtin_function ("__builtin_cos", double_ftype_double
,
11936 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos");
11937 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11938 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosl");
11941 pedantic_lvalues
= FALSE
;
11944 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11947 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11950 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11953 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11954 FFECOM_f2cDOUBLEREAL
,
11956 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11959 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11960 FFECOM_f2cDOUBLECOMPLEX
,
11962 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11965 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11968 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11971 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11974 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
11978 ffecom_f2c_ftnlen_zero_node
11979 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
11981 ffecom_f2c_ftnlen_one_node
11982 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
11984 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
11985 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
11987 ffecom_f2c_ptr_to_ftnlen_type_node
11988 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
11990 ffecom_f2c_ptr_to_ftnint_type_node
11991 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
11993 ffecom_f2c_ptr_to_integer_type_node
11994 = build_pointer_type (ffecom_f2c_integer_type_node
);
11996 ffecom_f2c_ptr_to_real_type_node
11997 = build_pointer_type (ffecom_f2c_real_type_node
);
11999 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12000 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12002 REAL_VALUE_TYPE point_5
;
12004 #ifdef REAL_ARITHMETIC
12005 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12009 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12010 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12013 /* Do "extern int xargc;". */
12015 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12016 get_identifier ("f__xargc"),
12017 integer_type_node
);
12018 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12019 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12020 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12021 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12022 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12024 #if 0 /* This is being fixed, and seems to be working now. */
12025 if ((FLOAT_TYPE_SIZE
!= 32)
12026 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12028 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12029 (int) FLOAT_TYPE_SIZE
);
12030 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12031 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12032 warning ("properly unless they all are 32 bits wide.");
12033 warning ("Please keep this in mind before you report bugs. g77 should");
12034 warning ("support non-32-bit machines better as of version 0.6.");
12038 #if 0 /* Code in ste.c that would crash has been commented out. */
12039 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12040 < TYPE_PRECISION (string_type_node
))
12041 /* I/O will probably crash. */
12042 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12043 TYPE_PRECISION (string_type_node
),
12044 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12047 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12048 if (TYPE_PRECISION (ffecom_integer_type_node
)
12049 < TYPE_PRECISION (string_type_node
))
12050 /* ASSIGN 10 TO I will crash. */
12051 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12052 ASSIGN statement might fail",
12053 TYPE_PRECISION (string_type_node
),
12054 TYPE_PRECISION (ffecom_integer_type_node
));
12059 /* ffecom_init_2 -- Initialize
12061 ffecom_init_2(); */
12063 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12067 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12068 assert (current_function_decl
== NULL_TREE
);
12069 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12071 ffecom_master_arglist_
= NULL
;
12073 ffecom_primary_entry_
= NULL
;
12074 ffecom_is_altreturning_
= FALSE
;
12075 ffecom_func_result_
= NULL_TREE
;
12076 ffecom_multi_retval_
= NULL_TREE
;
12080 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12083 ffebld expr; // FFE opITEM list.
12084 tree = ffecom_list_expr(expr);
12086 List of actual args is transformed into corresponding gcc backend list. */
12088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12090 ffecom_list_expr (ffebld expr
)
12093 tree
*plist
= &list
;
12094 tree trail
= NULL_TREE
; /* Append char length args here. */
12095 tree
*ptrail
= &trail
;
12098 while (expr
!= NULL
)
12100 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
12102 if (texpr
== error_mark_node
)
12103 return error_mark_node
;
12105 *plist
= build_tree_list (NULL_TREE
, texpr
);
12106 plist
= &TREE_CHAIN (*plist
);
12107 expr
= ffebld_trail (expr
);
12108 if (length
!= NULL_TREE
)
12110 *ptrail
= build_tree_list (NULL_TREE
, length
);
12111 ptrail
= &TREE_CHAIN (*ptrail
);
12121 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12124 ffebld expr; // FFE opITEM list.
12125 tree = ffecom_list_ptr_to_expr(expr);
12127 List of actual args is transformed into corresponding gcc backend list for
12128 use in calling an external procedure (vs. a statement function). */
12130 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12132 ffecom_list_ptr_to_expr (ffebld expr
)
12135 tree
*plist
= &list
;
12136 tree trail
= NULL_TREE
; /* Append char length args here. */
12137 tree
*ptrail
= &trail
;
12140 while (expr
!= NULL
)
12142 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
12144 if (texpr
== error_mark_node
)
12145 return error_mark_node
;
12147 *plist
= build_tree_list (NULL_TREE
, texpr
);
12148 plist
= &TREE_CHAIN (*plist
);
12149 expr
= ffebld_trail (expr
);
12150 if (length
!= NULL_TREE
)
12152 *ptrail
= build_tree_list (NULL_TREE
, length
);
12153 ptrail
= &TREE_CHAIN (*ptrail
);
12163 /* Obtain gcc's LABEL_DECL tree for label. */
12165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12167 ffecom_lookup_label (ffelab label
)
12171 if (ffelab_hook (label
) == NULL_TREE
)
12173 char labelname
[16];
12175 switch (ffelab_type (label
))
12177 case FFELAB_typeLOOPEND
:
12178 case FFELAB_typeNOTLOOP
:
12179 case FFELAB_typeENDIF
:
12180 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12181 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12183 DECL_CONTEXT (glabel
) = current_function_decl
;
12184 DECL_MODE (glabel
) = VOIDmode
;
12187 case FFELAB_typeFORMAT
:
12188 glabel
= build_decl (VAR_DECL
,
12189 ffecom_get_invented_identifier
12190 ("__g77_format_%d", (int) ffelab_value (label
)),
12191 build_type_variant (build_array_type
12195 TREE_CONSTANT (glabel
) = 1;
12196 TREE_STATIC (glabel
) = 1;
12197 DECL_CONTEXT (glabel
) = current_function_decl
;
12198 DECL_INITIAL (glabel
) = NULL
;
12199 make_decl_rtl (glabel
, NULL
);
12200 expand_decl (glabel
);
12202 ffecom_save_tree_forever (glabel
);
12206 case FFELAB_typeANY
:
12207 glabel
= error_mark_node
;
12211 assert ("bad label type" == NULL
);
12215 ffelab_set_hook (label
, glabel
);
12219 glabel
= ffelab_hook (label
);
12226 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12227 a single source specification (as in the fourth argument of MVBITS).
12228 If the type is NULL_TREE, the type of lhs is used to make the type of
12229 the MODIFY_EXPR. */
12231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12233 ffecom_modify (tree newtype
, tree lhs
,
12236 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12237 return error_mark_node
;
12239 if (newtype
== NULL_TREE
)
12240 newtype
= TREE_TYPE (lhs
);
12242 if (TREE_SIDE_EFFECTS (lhs
))
12243 lhs
= stabilize_reference (lhs
);
12245 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12250 /* Register source file name. */
12253 ffecom_file (const char *name
)
12255 #if FFECOM_GCC_INCLUDE
12256 ffecom_file_ (name
);
12260 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12263 ffecom_notify_init_storage(st);
12265 Gets called when all possible units in an aggregate storage area (a LOCAL
12266 with equivalences or a COMMON) have been initialized. The initialization
12267 info either is in ffestorag_init or, if that is NULL,
12268 ffestorag_accretion:
12270 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12271 even for an array if the array is one element in length!
12273 ffestorag_accretion will contain an opACCTER. It is much like an
12274 opARRTER except it has an ffebit object in it instead of just a size.
12275 The back end can use the info in the ffebit object, if it wants, to
12276 reduce the amount of actual initialization, but in any case it should
12277 kill the ffebit object when done. Also, set accretion to NULL but
12278 init to a non-NULL value.
12280 After performing initialization, DO NOT set init to NULL, because that'll
12281 tell the front end it is ok for more initialization to happen. Instead,
12282 set init to an opANY expression or some such thing that you can use to
12283 tell that you've already initialized the object.
12286 Support two-pass FFE. */
12289 ffecom_notify_init_storage (ffestorag st
)
12291 ffebld init
; /* The initialization expression. */
12292 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12293 ffetargetOffset size
; /* The size of the entity. */
12294 ffetargetAlign pad
; /* Its initial padding. */
12297 if (ffestorag_init (st
) == NULL
)
12299 init
= ffestorag_accretion (st
);
12300 assert (init
!= NULL
);
12301 ffestorag_set_accretion (st
, NULL
);
12302 ffestorag_set_accretes (st
, 0);
12304 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12305 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12306 size
= ffebld_accter_size (init
);
12307 pad
= ffebld_accter_pad (init
);
12308 ffebit_kill (ffebld_accter_bits (init
));
12309 ffebld_set_op (init
, FFEBLD_opARRTER
);
12310 ffebld_set_arrter (init
, ffebld_accter (init
));
12311 ffebld_arrter_set_size (init
, size
);
12312 ffebld_arrter_set_pad (init
, size
);
12316 ffestorag_set_init (st
, init
);
12321 init
= ffestorag_init (st
);
12324 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12325 ffestorag_set_init (st
, ffebld_new_any ());
12327 if (ffebld_op (init
) == FFEBLD_opANY
)
12328 return; /* Oh, we already did this! */
12330 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12334 if (ffestorag_symbol (st
) != NULL
)
12335 s
= ffestorag_symbol (st
);
12337 s
= ffestorag_typesymbol (st
);
12339 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12340 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12341 ffebld_dump (init
);
12342 fputc ('\n', dmpout
);
12346 #endif /* if FFECOM_ONEPASS */
12349 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12352 ffecom_notify_init_symbol(s);
12354 Gets called when all possible units in a symbol (not placed in COMMON
12355 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12356 have been initialized. The initialization info either is in
12357 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12359 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12360 even for an array if the array is one element in length!
12362 ffesymbol_accretion will contain an opACCTER. It is much like an
12363 opARRTER except it has an ffebit object in it instead of just a size.
12364 The back end can use the info in the ffebit object, if it wants, to
12365 reduce the amount of actual initialization, but in any case it should
12366 kill the ffebit object when done. Also, set accretion to NULL but
12367 init to a non-NULL value.
12369 After performing initialization, DO NOT set init to NULL, because that'll
12370 tell the front end it is ok for more initialization to happen. Instead,
12371 set init to an opANY expression or some such thing that you can use to
12372 tell that you've already initialized the object.
12375 Support two-pass FFE. */
12378 ffecom_notify_init_symbol (ffesymbol s
)
12380 ffebld init
; /* The initialization expression. */
12381 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12382 ffetargetOffset size
; /* The size of the entity. */
12383 ffetargetAlign pad
; /* Its initial padding. */
12386 if (ffesymbol_storage (s
) == NULL
)
12387 return; /* Do nothing until COMMON/EQUIVALENCE
12388 possibilities checked. */
12390 if ((ffesymbol_init (s
) == NULL
)
12391 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12393 ffesymbol_set_accretion (s
, NULL
);
12394 ffesymbol_set_accretes (s
, 0);
12396 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12397 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12398 size
= ffebld_accter_size (init
);
12399 pad
= ffebld_accter_pad (init
);
12400 ffebit_kill (ffebld_accter_bits (init
));
12401 ffebld_set_op (init
, FFEBLD_opARRTER
);
12402 ffebld_set_arrter (init
, ffebld_accter (init
));
12403 ffebld_arrter_set_size (init
, size
);
12404 ffebld_arrter_set_pad (init
, size
);
12408 ffesymbol_set_init (s
, init
);
12413 init
= ffesymbol_init (s
);
12417 ffesymbol_set_init (s
, ffebld_new_any ());
12419 if (ffebld_op (init
) == FFEBLD_opANY
)
12420 return; /* Oh, we already did this! */
12422 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12423 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12424 ffebld_dump (init
);
12425 fputc ('\n', dmpout
);
12428 #endif /* if FFECOM_ONEPASS */
12431 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12434 ffecom_notify_primary_entry(s);
12436 Gets called when implicit or explicit PROGRAM statement seen or when
12437 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12438 global symbol that serves as the entry point. */
12441 ffecom_notify_primary_entry (ffesymbol s
)
12443 ffecom_primary_entry_
= s
;
12444 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12446 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12447 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12448 ffecom_primary_entry_is_proc_
= TRUE
;
12450 ffecom_primary_entry_is_proc_
= FALSE
;
12452 if (!ffe_is_silent ())
12454 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12455 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12457 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12461 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12466 for (list
= ffesymbol_dummyargs (s
);
12468 list
= ffebld_trail (list
))
12470 arg
= ffebld_head (list
);
12471 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12473 ffecom_is_altreturning_
= TRUE
;
12482 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12484 #if FFECOM_GCC_INCLUDE
12485 return ffecom_open_include_ (name
, l
, c
);
12487 return fopen (name
, "r");
12491 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12494 ffebld expr; // FFE expression.
12495 tree = ffecom_ptr_to_expr(expr);
12497 Like ffecom_expr, but sticks address-of in front of most things. */
12499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12501 ffecom_ptr_to_expr (ffebld expr
)
12504 ffeinfoBasictype bt
;
12505 ffeinfoKindtype kt
;
12508 assert (expr
!= NULL
);
12510 switch (ffebld_op (expr
))
12512 case FFEBLD_opSYMTER
:
12513 s
= ffebld_symter (expr
);
12514 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12518 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12519 assert (ix
!= FFECOM_gfrt
);
12520 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12522 ffecom_make_gfrt_ (ix
);
12523 item
= ffecom_gfrt_
[ix
];
12528 item
= ffesymbol_hook (s
).decl_tree
;
12529 if (item
== NULL_TREE
)
12531 s
= ffecom_sym_transform_ (s
);
12532 item
= ffesymbol_hook (s
).decl_tree
;
12535 assert (item
!= NULL
);
12536 if (item
== error_mark_node
)
12538 if (!ffesymbol_hook (s
).addr
)
12539 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12543 case FFEBLD_opARRAYREF
:
12544 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12546 case FFEBLD_opCONTER
:
12548 bt
= ffeinfo_basictype (ffebld_info (expr
));
12549 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12551 item
= ffecom_constantunion (&ffebld_constant_union
12552 (ffebld_conter (expr
)), bt
, kt
,
12553 ffecom_tree_type
[bt
][kt
]);
12554 if (item
== error_mark_node
)
12555 return error_mark_node
;
12556 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12561 return error_mark_node
;
12564 bt
= ffeinfo_basictype (ffebld_info (expr
));
12565 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12567 item
= ffecom_expr (expr
);
12568 if (item
== error_mark_node
)
12569 return error_mark_node
;
12571 /* The back end currently optimizes a bit too zealously for us, in that
12572 we fail JCB001 if the following block of code is omitted. It checks
12573 to see if the transformed expression is a symbol or array reference,
12574 and encloses it in a SAVE_EXPR if that is the case. */
12577 if ((TREE_CODE (item
) == VAR_DECL
)
12578 || (TREE_CODE (item
) == PARM_DECL
)
12579 || (TREE_CODE (item
) == RESULT_DECL
)
12580 || (TREE_CODE (item
) == INDIRECT_REF
)
12581 || (TREE_CODE (item
) == ARRAY_REF
)
12582 || (TREE_CODE (item
) == COMPONENT_REF
)
12584 || (TREE_CODE (item
) == OFFSET_REF
)
12586 || (TREE_CODE (item
) == BUFFER_REF
)
12587 || (TREE_CODE (item
) == REALPART_EXPR
)
12588 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12590 item
= ffecom_save_tree (item
);
12593 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12598 assert ("fall-through error" == NULL
);
12599 return error_mark_node
;
12603 /* Obtain a temp var with given data type.
12605 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12606 or >= 0 for a CHARACTER type.
12608 elements is -1 for a scalar or > 0 for an array of type. */
12610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12612 ffecom_make_tempvar (const char *commentary
, tree type
,
12613 ffetargetCharacterSize size
, int elements
)
12616 static int mynumber
;
12618 assert (current_binding_level
->prep_state
< 2);
12620 if (type
== error_mark_node
)
12621 return error_mark_node
;
12623 if (size
!= FFETARGET_charactersizeNONE
)
12624 type
= build_array_type (type
,
12625 build_range_type (ffecom_f2c_ftnlen_type_node
,
12626 ffecom_f2c_ftnlen_one_node
,
12627 build_int_2 (size
, 0)));
12628 if (elements
!= -1)
12629 type
= build_array_type (type
,
12630 build_range_type (integer_type_node
,
12632 build_int_2 (elements
- 1,
12634 t
= build_decl (VAR_DECL
,
12635 ffecom_get_invented_identifier ("__g77_%s_%d",
12640 t
= start_decl (t
, FALSE
);
12641 finish_decl (t
, NULL_TREE
, FALSE
);
12647 /* Prepare argument pointer to expression.
12649 Like ffecom_prepare_expr, except for expressions to be evaluated
12650 via ffecom_arg_ptr_to_expr. */
12653 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12655 /* ~~For now, it seems to be the same thing. */
12656 ffecom_prepare_expr (expr
);
12660 /* End of preparations. */
12663 ffecom_prepare_end (void)
12665 int prep_state
= current_binding_level
->prep_state
;
12667 assert (prep_state
< 2);
12668 current_binding_level
->prep_state
= 2;
12670 return (prep_state
== 1) ? TRUE
: FALSE
;
12673 /* Prepare expression.
12675 This is called before any code is generated for the current block.
12676 It scans the expression, declares any temporaries that might be needed
12677 during evaluation of the expression, and stores those temporaries in
12678 the appropriate "hook" fields of the expression. `dest', if not NULL,
12679 specifies the destination that ffecom_expr_ will see, in case that
12680 helps avoid generating unused temporaries.
12682 ~~Improve to avoid allocating unused temporaries by taking `dest'
12683 into account vis-a-vis aliasing requirements of complex/character
12687 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12689 ffeinfoBasictype bt
;
12690 ffeinfoKindtype kt
;
12691 ffetargetCharacterSize sz
;
12692 tree tempvar
= NULL_TREE
;
12694 assert (current_binding_level
->prep_state
< 2);
12699 bt
= ffeinfo_basictype (ffebld_info (expr
));
12700 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12701 sz
= ffeinfo_size (ffebld_info (expr
));
12703 /* Generate whatever temporaries are needed to represent the result
12704 of the expression. */
12706 if (bt
== FFEINFO_basictypeCHARACTER
)
12708 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12709 expr
= ffebld_left (expr
);
12712 switch (ffebld_op (expr
))
12715 /* Don't make temps for SYMTER, CONTER, etc. */
12716 if (ffebld_arity (expr
) == 0)
12721 case FFEINFO_basictypeCOMPLEX
:
12722 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12726 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12729 s
= ffebld_symter (ffebld_left (expr
));
12730 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12731 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12732 && ! ffesymbol_is_f2c (s
))
12733 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12734 && ! ffe_is_f2c_library ()))
12737 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12739 /* Requires special treatment. There's no POW_CC function
12740 in libg2c, so POW_ZZ is used, which means we always
12741 need a double-complex temp, not a single-complex. */
12742 kt
= FFEINFO_kindtypeREAL2
;
12744 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12745 /* The other ops don't need temps for complex operands. */
12748 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12749 REAL(C). See 19990325-0.f, routine `check', for cases. */
12750 tempvar
= ffecom_make_tempvar ("complex",
12752 [FFEINFO_basictypeCOMPLEX
][kt
],
12753 FFETARGET_charactersizeNONE
,
12757 case FFEINFO_basictypeCHARACTER
:
12758 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12761 if (sz
== FFETARGET_charactersizeNONE
)
12762 /* ~~Kludge alert! This should someday be fixed. */
12765 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12774 case FFEBLD_opPOWER
:
12777 tree rtmp
, ltmp
, result
;
12779 ltype
= ffecom_type_expr (ffebld_left (expr
));
12780 rtype
= ffecom_type_expr (ffebld_right (expr
));
12782 rtmp
= ffecom_make_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1);
12783 ltmp
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12784 result
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12786 tempvar
= make_tree_vec (3);
12787 TREE_VEC_ELT (tempvar
, 0) = rtmp
;
12788 TREE_VEC_ELT (tempvar
, 1) = ltmp
;
12789 TREE_VEC_ELT (tempvar
, 2) = result
;
12794 case FFEBLD_opCONCATENATE
:
12796 /* This gets special handling, because only one set of temps
12797 is needed for a tree of these -- the tree is treated as
12798 a flattened list of concatenations when generating code. */
12800 ffecomConcatList_ catlist
;
12801 tree ltmp
, itmp
, result
;
12805 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12806 count
= ffecom_concat_list_count_ (catlist
);
12811 = ffecom_make_tempvar ("concat_len",
12812 ffecom_f2c_ftnlen_type_node
,
12813 FFETARGET_charactersizeNONE
, count
);
12815 = ffecom_make_tempvar ("concat_item",
12816 ffecom_f2c_address_type_node
,
12817 FFETARGET_charactersizeNONE
, count
);
12819 = ffecom_make_tempvar ("concat_res",
12821 ffecom_concat_list_maxlen_ (catlist
),
12824 tempvar
= make_tree_vec (3);
12825 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12826 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12827 TREE_VEC_ELT (tempvar
, 2) = result
;
12830 for (i
= 0; i
< count
; ++i
)
12831 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12834 ffecom_concat_list_kill_ (catlist
);
12838 ffebld_nonter_set_hook (expr
, tempvar
);
12839 current_binding_level
->prep_state
= 1;
12844 case FFEBLD_opCONVERT
:
12845 if (bt
== FFEINFO_basictypeCHARACTER
12846 && ((ffebld_size_known (ffebld_left (expr
))
12847 == FFETARGET_charactersizeNONE
)
12848 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12849 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12855 ffebld_nonter_set_hook (expr
, tempvar
);
12856 current_binding_level
->prep_state
= 1;
12859 /* Prepare subexpressions for this expr. */
12861 switch (ffebld_op (expr
))
12863 case FFEBLD_opPERCENT_LOC
:
12864 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12867 case FFEBLD_opPERCENT_VAL
:
12868 case FFEBLD_opPERCENT_REF
:
12869 ffecom_prepare_expr (ffebld_left (expr
));
12872 case FFEBLD_opPERCENT_DESCR
:
12873 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12876 case FFEBLD_opITEM
:
12882 item
= ffebld_trail (item
))
12883 if (ffebld_head (item
) != NULL
)
12884 ffecom_prepare_expr (ffebld_head (item
));
12889 /* Need to handle character conversion specially. */
12890 switch (ffebld_arity (expr
))
12893 ffecom_prepare_expr (ffebld_left (expr
));
12894 ffecom_prepare_expr (ffebld_right (expr
));
12898 ffecom_prepare_expr (ffebld_left (expr
));
12909 /* Prepare expression for reading and writing.
12911 Like ffecom_prepare_expr, except for expressions to be evaluated
12912 via ffecom_expr_rw. */
12915 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12917 /* This is all we support for now. */
12918 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12920 /* ~~For now, it seems to be the same thing. */
12921 ffecom_prepare_expr (expr
);
12925 /* Prepare expression for writing.
12927 Like ffecom_prepare_expr, except for expressions to be evaluated
12928 via ffecom_expr_w. */
12931 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12933 /* This is all we support for now. */
12934 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12936 /* ~~For now, it seems to be the same thing. */
12937 ffecom_prepare_expr (expr
);
12941 /* Prepare expression for returning.
12943 Like ffecom_prepare_expr, except for expressions to be evaluated
12944 via ffecom_return_expr. */
12947 ffecom_prepare_return_expr (ffebld expr
)
12949 assert (current_binding_level
->prep_state
< 2);
12951 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12952 && ffecom_is_altreturning_
12954 ffecom_prepare_expr (expr
);
12957 /* Prepare pointer to expression.
12959 Like ffecom_prepare_expr, except for expressions to be evaluated
12960 via ffecom_ptr_to_expr. */
12963 ffecom_prepare_ptr_to_expr (ffebld expr
)
12965 /* ~~For now, it seems to be the same thing. */
12966 ffecom_prepare_expr (expr
);
12970 /* Transform expression into constant pointer-to-expression tree.
12972 If the expression can be transformed into a pointer-to-expression tree
12973 that is constant, that is done, and the tree returned. Else NULL_TREE
12976 That way, a caller can attempt to provide compile-time initialization
12977 of a variable and, if that fails, *then* choose to start a new block
12978 and resort to using temporaries, as appropriate. */
12981 ffecom_ptr_to_const_expr (ffebld expr
)
12984 return integer_zero_node
;
12986 if (ffebld_op (expr
) == FFEBLD_opANY
)
12987 return error_mark_node
;
12989 if (ffebld_arity (expr
) == 0
12990 && (ffebld_op (expr
) != FFEBLD_opSYMTER
12991 || ffebld_where (expr
) == FFEINFO_whereCOMMON
12992 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
12993 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
12997 t
= ffecom_ptr_to_expr (expr
);
12998 assert (TREE_CONSTANT (t
));
13005 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13007 tree rtn; // NULL_TREE means use expand_null_return()
13008 ffebld expr; // NULL if no alt return expr to RETURN stmt
13009 rtn = ffecom_return_expr(expr);
13011 Based on the program unit type and other info (like return function
13012 type, return master function type when alternate ENTRY points,
13013 whether subroutine has any alternate RETURN points, etc), returns the
13014 appropriate expression to be returned to the caller, or NULL_TREE
13015 meaning no return value or the caller expects it to be returned somewhere
13016 else (which is handled by other parts of this module). */
13018 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13020 ffecom_return_expr (ffebld expr
)
13024 switch (ffecom_primary_entry_kind_
)
13026 case FFEINFO_kindPROGRAM
:
13027 case FFEINFO_kindBLOCKDATA
:
13031 case FFEINFO_kindSUBROUTINE
:
13032 if (!ffecom_is_altreturning_
)
13033 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13034 else if (expr
== NULL
)
13035 rtn
= integer_zero_node
;
13037 rtn
= ffecom_expr (expr
);
13040 case FFEINFO_kindFUNCTION
:
13041 if ((ffecom_multi_retval_
!= NULL_TREE
)
13042 || (ffesymbol_basictype (ffecom_primary_entry_
)
13043 == FFEINFO_basictypeCHARACTER
)
13044 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13045 == FFEINFO_basictypeCOMPLEX
)
13046 && (ffecom_num_entrypoints_
== 0)
13047 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13048 { /* Value is returned by direct assignment
13049 into (implicit) dummy. */
13053 rtn
= ffecom_func_result_
;
13055 /* Spurious error if RETURN happens before first reference! So elide
13056 this code. In particular, for debugging registry, rtn should always
13057 be non-null after all, but TREE_USED won't be set until we encounter
13058 a reference in the code. Perfectly okay (but weird) code that,
13059 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13060 this diagnostic for no reason. Have people use -O -Wuninitialized
13061 and leave it to the back end to find obviously weird cases. */
13063 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13064 situation; if the return value has never been referenced, it won't
13065 have a tree under 2pass mode. */
13066 if ((rtn
== NULL_TREE
)
13067 || !TREE_USED (rtn
))
13069 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13070 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13071 ffesymbol_where_column (ffecom_primary_entry_
));
13072 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13073 (ffecom_primary_entry_
)));
13080 assert ("bad unit kind" == NULL
);
13081 case FFEINFO_kindANY
:
13082 rtn
= error_mark_node
;
13090 /* Do save_expr only if tree is not error_mark_node. */
13092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13094 ffecom_save_tree (tree t
)
13096 return save_expr (t
);
13100 /* Start a compound statement (block). */
13102 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13104 ffecom_start_compstmt (void)
13106 bison_rule_pushlevel_ ();
13108 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13110 /* Public entry point for front end to access start_decl. */
13112 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13114 ffecom_start_decl (tree decl
, bool is_initialized
)
13116 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13117 return start_decl (decl
, FALSE
);
13121 /* ffecom_sym_commit -- Symbol's state being committed to reality
13124 ffecom_sym_commit(s);
13126 Does whatever the backend needs when a symbol is committed after having
13127 been backtrackable for a period of time. */
13129 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13131 ffecom_sym_commit (ffesymbol s UNUSED
)
13133 assert (!ffesymbol_retractable ());
13137 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13139 ffecom_sym_end_transition();
13141 Does backend-specific stuff and also calls ffest_sym_end_transition
13142 to do the necessary FFE stuff.
13144 Backtracking is never enabled when this fn is called, so don't worry
13148 ffecom_sym_end_transition (ffesymbol s
)
13152 assert (!ffesymbol_retractable ());
13154 s
= ffest_sym_end_transition (s
);
13156 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13157 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13158 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13160 ffecom_list_blockdata_
13161 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13162 FFEINTRIN_specNONE
,
13163 FFEINTRIN_impNONE
),
13164 ffecom_list_blockdata_
);
13168 /* This is where we finally notice that a symbol has partial initialization
13169 and finalize it. */
13171 if (ffesymbol_accretion (s
) != NULL
)
13173 assert (ffesymbol_init (s
) == NULL
);
13174 ffecom_notify_init_symbol (s
);
13176 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13177 && ((st
= ffestorag_parent (st
)) != NULL
)
13178 && (ffestorag_accretion (st
) != NULL
))
13180 assert (ffestorag_init (st
) == NULL
);
13181 ffecom_notify_init_storage (st
);
13184 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13185 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13186 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13187 && (ffesymbol_storage (s
) != NULL
))
13189 ffecom_list_common_
13190 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13191 FFEINTRIN_specNONE
,
13192 FFEINTRIN_impNONE
),
13193 ffecom_list_common_
);
13200 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13202 ffecom_sym_exec_transition();
13204 Does backend-specific stuff and also calls ffest_sym_exec_transition
13205 to do the necessary FFE stuff.
13207 See the long-winded description in ffecom_sym_learned for info
13208 on handling the situation where backtracking is inhibited. */
13211 ffecom_sym_exec_transition (ffesymbol s
)
13213 s
= ffest_sym_exec_transition (s
);
13218 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13221 s = ffecom_sym_learned(s);
13223 Called when a new symbol is seen after the exec transition or when more
13224 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13225 it arrives here is that all its latest info is updated already, so its
13226 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13227 field filled in if its gone through here or exec_transition first, and
13230 The backend probably wants to check ffesymbol_retractable() to see if
13231 backtracking is in effect. If so, the FFE's changes to the symbol may
13232 be retracted (undone) or committed (ratified), at which time the
13233 appropriate ffecom_sym_retract or _commit function will be called
13236 If the backend has its own backtracking mechanism, great, use it so that
13237 committal is a simple operation. Though it doesn't make much difference,
13238 I suppose: the reason for tentative symbol evolution in the FFE is to
13239 enable error detection in weird incorrect statements early and to disable
13240 incorrect error detection on a correct statement. The backend is not
13241 likely to introduce any information that'll get involved in these
13242 considerations, so it is probably just fine that the implementation
13243 model for this fn and for _exec_transition is to not do anything
13244 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13245 and instead wait until ffecom_sym_commit is called (which it never
13246 will be as long as we're using ambiguity-detecting statement analysis in
13247 the FFE, which we are initially to shake out the code, but don't depend
13248 on this), otherwise go ahead and do whatever is needed.
13250 In essence, then, when this fn and _exec_transition get called while
13251 backtracking is enabled, a general mechanism would be to flag which (or
13252 both) of these were called (and in what order? neat question as to what
13253 might happen that I'm too lame to think through right now) and then when
13254 _commit is called reproduce the original calling sequence, if any, for
13255 the two fns (at which point backtracking will, of course, be disabled). */
13258 ffecom_sym_learned (ffesymbol s
)
13260 ffestorag_exec_layout (s
);
13265 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13268 ffecom_sym_retract(s);
13270 Does whatever the backend needs when a symbol is retracted after having
13271 been backtrackable for a period of time. */
13273 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13275 ffecom_sym_retract (ffesymbol s UNUSED
)
13277 assert (!ffesymbol_retractable ());
13279 #if 0 /* GCC doesn't commit any backtrackable sins,
13280 so nothing needed here. */
13281 switch (ffesymbol_hook (s
).state
)
13283 case 0: /* nothing happened yet. */
13286 case 1: /* exec transition happened. */
13289 case 2: /* learned happened. */
13292 case 3: /* learned then exec. */
13295 case 4: /* exec then learned. */
13299 assert ("bad hook state" == NULL
);
13306 /* Create temporary gcc label. */
13308 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13310 ffecom_temp_label ()
13313 static int mynumber
= 0;
13315 glabel
= build_decl (LABEL_DECL
,
13316 ffecom_get_invented_identifier ("__g77_label_%d",
13319 DECL_CONTEXT (glabel
) = current_function_decl
;
13320 DECL_MODE (glabel
) = VOIDmode
;
13326 /* Return an expression that is usable as an arg in a conditional context
13327 (IF, DO WHILE, .NOT., and so on).
13329 Use the one provided for the back end as of >2.6.0. */
13331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13333 ffecom_truth_value (tree expr
)
13335 return truthvalue_conversion (expr
);
13339 /* Return the inversion of a truth value (the inversion of what
13340 ffecom_truth_value builds).
13342 Apparently invert_truthvalue, which is properly in the back end, is
13343 enough for now, so just use it. */
13345 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13347 ffecom_truth_value_invert (tree expr
)
13349 return invert_truthvalue (ffecom_truth_value (expr
));
13354 /* Return the tree that is the type of the expression, as would be
13355 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13356 transforming the expression, generating temporaries, etc. */
13359 ffecom_type_expr (ffebld expr
)
13361 ffeinfoBasictype bt
;
13362 ffeinfoKindtype kt
;
13365 assert (expr
!= NULL
);
13367 bt
= ffeinfo_basictype (ffebld_info (expr
));
13368 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13369 tree_type
= ffecom_tree_type
[bt
][kt
];
13371 switch (ffebld_op (expr
))
13373 case FFEBLD_opCONTER
:
13374 case FFEBLD_opSYMTER
:
13375 case FFEBLD_opARRAYREF
:
13376 case FFEBLD_opUPLUS
:
13377 case FFEBLD_opPAREN
:
13378 case FFEBLD_opUMINUS
:
13380 case FFEBLD_opSUBTRACT
:
13381 case FFEBLD_opMULTIPLY
:
13382 case FFEBLD_opDIVIDE
:
13383 case FFEBLD_opPOWER
:
13385 case FFEBLD_opFUNCREF
:
13386 case FFEBLD_opSUBRREF
:
13390 case FFEBLD_opNEQV
:
13392 case FFEBLD_opCONVERT
:
13399 case FFEBLD_opPERCENT_LOC
:
13402 case FFEBLD_opACCTER
:
13403 case FFEBLD_opARRTER
:
13404 case FFEBLD_opITEM
:
13405 case FFEBLD_opSTAR
:
13406 case FFEBLD_opBOUNDS
:
13407 case FFEBLD_opREPEAT
:
13408 case FFEBLD_opLABTER
:
13409 case FFEBLD_opLABTOK
:
13410 case FFEBLD_opIMPDO
:
13411 case FFEBLD_opCONCATENATE
:
13412 case FFEBLD_opSUBSTR
:
13414 assert ("bad op for ffecom_type_expr" == NULL
);
13415 /* Fall through. */
13417 return error_mark_node
;
13421 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13423 If the PARM_DECL already exists, return it, else create it. It's an
13424 integer_type_node argument for the master function that implements a
13425 subroutine or function with more than one entrypoint and is bound at
13426 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13427 first ENTRY statement, and so on). */
13429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13431 ffecom_which_entrypoint_decl ()
13433 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13435 return ffecom_which_entrypoint_decl_
;
13440 /* The following sections consists of private and public functions
13441 that have the same names and perform roughly the same functions
13442 as counterparts in the C front end. Changes in the C front end
13443 might affect how things should be done here. Only functions
13444 needed by the back end should be public here; the rest should
13445 be private (static in the C sense). Functions needed by other
13446 g77 front-end modules should be accessed by them via public
13447 ffecom_* names, which should themselves call private versions
13448 in this section so the private versions are easy to recognize
13449 when upgrading to a new gcc and finding interesting changes
13452 Functions named after rule "foo:" in c-parse.y are named
13453 "bison_rule_foo_" so they are easy to find. */
13455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13458 bison_rule_pushlevel_ ()
13460 emit_line_note (input_filename
, lineno
);
13462 clear_last_expr ();
13463 expand_start_bindings (0);
13467 bison_rule_compstmt_ ()
13470 int keep
= kept_level_p ();
13472 /* Make the temps go away. */
13474 current_binding_level
->names
= NULL_TREE
;
13476 emit_line_note (input_filename
, lineno
);
13477 expand_end_bindings (getdecls (), keep
, 0);
13478 t
= poplevel (keep
, 1, 0);
13483 /* Return a definition for a builtin function named NAME and whose data type
13484 is TYPE. TYPE should be a function type with argument types.
13485 FUNCTION_CODE tells later passes how to compile calls to this function.
13486 See tree.h for its possible values.
13488 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13489 the name to be called if we can't opencode the function. */
13492 builtin_function (const char *name
, tree type
, int function_code
,
13493 enum built_in_class
class,
13494 const char *library_name
)
13496 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13497 DECL_EXTERNAL (decl
) = 1;
13498 TREE_PUBLIC (decl
) = 1;
13500 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13501 make_decl_rtl (decl
, NULL_PTR
);
13503 DECL_BUILT_IN_CLASS (decl
) = class;
13504 DECL_FUNCTION_CODE (decl
) = function_code
;
13509 /* Handle when a new declaration NEWDECL
13510 has the same name as an old one OLDDECL
13511 in the same binding contour.
13512 Prints an error message if appropriate.
13514 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13515 Otherwise, return 0. */
13518 duplicate_decls (tree newdecl
, tree olddecl
)
13520 int types_match
= 1;
13521 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13522 && DECL_INITIAL (newdecl
) != 0);
13523 tree oldtype
= TREE_TYPE (olddecl
);
13524 tree newtype
= TREE_TYPE (newdecl
);
13526 if (olddecl
== newdecl
)
13529 if (TREE_CODE (newtype
) == ERROR_MARK
13530 || TREE_CODE (oldtype
) == ERROR_MARK
)
13533 /* New decl is completely inconsistent with the old one =>
13534 tell caller to replace the old one.
13535 This is always an error except in the case of shadowing a builtin. */
13536 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13539 /* For real parm decl following a forward decl,
13540 return 1 so old decl will be reused. */
13541 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13542 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13545 /* The new declaration is the same kind of object as the old one.
13546 The declarations may partially match. Print warnings if they don't
13547 match enough. Ultimately, copy most of the information from the new
13548 decl to the old one, and keep using the old one. */
13550 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13551 && DECL_BUILT_IN (olddecl
))
13553 /* A function declaration for a built-in function. */
13554 if (!TREE_PUBLIC (newdecl
))
13556 else if (!types_match
)
13558 /* Accept the return type of the new declaration if same modes. */
13559 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13560 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13562 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13564 /* Function types may be shared, so we can't just modify
13565 the return type of olddecl's function type. */
13567 = build_function_type (newreturntype
,
13568 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13572 TREE_TYPE (olddecl
) = newtype
;
13578 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13579 && DECL_SOURCE_LINE (olddecl
) == 0)
13581 /* A function declaration for a predeclared function
13582 that isn't actually built in. */
13583 if (!TREE_PUBLIC (newdecl
))
13585 else if (!types_match
)
13587 /* If the types don't match, preserve volatility indication.
13588 Later on, we will discard everything else about the
13589 default declaration. */
13590 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13594 /* Copy all the DECL_... slots specified in the new decl
13595 except for any that we copy here from the old type.
13597 Past this point, we don't change OLDTYPE and NEWTYPE
13598 even if we change the types of NEWDECL and OLDDECL. */
13602 /* Merge the data types specified in the two decls. */
13603 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13604 TREE_TYPE (newdecl
)
13605 = TREE_TYPE (olddecl
)
13606 = TREE_TYPE (newdecl
);
13608 /* Lay the type out, unless already done. */
13609 if (oldtype
!= TREE_TYPE (newdecl
))
13611 if (TREE_TYPE (newdecl
) != error_mark_node
)
13612 layout_type (TREE_TYPE (newdecl
));
13613 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13614 && TREE_CODE (newdecl
) != TYPE_DECL
13615 && TREE_CODE (newdecl
) != CONST_DECL
)
13616 layout_decl (newdecl
, 0);
13620 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13621 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13622 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13623 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13624 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13626 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13627 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13631 /* Keep the old rtl since we can safely use it. */
13632 COPY_DECL_RTL (newdecl
, olddecl
);
13634 /* Merge the type qualifiers. */
13635 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13636 && !TREE_THIS_VOLATILE (newdecl
))
13637 TREE_THIS_VOLATILE (olddecl
) = 0;
13638 if (TREE_READONLY (newdecl
))
13639 TREE_READONLY (olddecl
) = 1;
13640 if (TREE_THIS_VOLATILE (newdecl
))
13642 TREE_THIS_VOLATILE (olddecl
) = 1;
13643 if (TREE_CODE (newdecl
) == VAR_DECL
)
13644 make_var_volatile (newdecl
);
13647 /* Keep source location of definition rather than declaration.
13648 Likewise, keep decl at outer scope. */
13649 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13650 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13652 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13653 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13655 if (DECL_CONTEXT (olddecl
) == 0
13656 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13657 DECL_CONTEXT (newdecl
) = 0;
13660 /* Merge the unused-warning information. */
13661 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13662 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13663 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13664 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13666 /* Merge the initialization information. */
13667 if (DECL_INITIAL (newdecl
) == 0)
13668 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13670 /* Merge the section attribute.
13671 We want to issue an error if the sections conflict but that must be
13672 done later in decl_attributes since we are called before attributes
13674 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13675 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13678 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13680 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13681 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13685 /* If cannot merge, then use the new type and qualifiers,
13686 and don't preserve the old rtl. */
13689 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13690 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13691 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13692 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13695 /* Merge the storage class information. */
13696 /* For functions, static overrides non-static. */
13697 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13699 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13700 /* This is since we don't automatically
13701 copy the attributes of NEWDECL into OLDDECL. */
13702 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13703 /* If this clears `static', clear it in the identifier too. */
13704 if (! TREE_PUBLIC (olddecl
))
13705 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13707 if (DECL_EXTERNAL (newdecl
))
13709 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13710 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13711 /* An extern decl does not override previous storage class. */
13712 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13716 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13717 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13720 /* If either decl says `inline', this fn is inline,
13721 unless its definition was passed already. */
13722 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13723 DECL_INLINE (olddecl
) = 1;
13724 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13726 /* Get rid of any built-in function if new arg types don't match it
13727 or if we have a function definition. */
13728 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13729 && DECL_BUILT_IN (olddecl
)
13730 && (!types_match
|| new_is_definition
))
13732 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13733 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13736 /* If redeclaring a builtin function, and not a definition,
13738 Also preserve various other info from the definition. */
13739 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13741 if (DECL_BUILT_IN (olddecl
))
13743 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13744 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13747 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
13749 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13750 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13751 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13752 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13755 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13756 But preserve olddecl's DECL_UID. */
13758 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13760 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13761 (char *) newdecl
+ sizeof (struct tree_common
),
13762 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13763 DECL_UID (olddecl
) = olddecl_uid
;
13769 /* Finish processing of a declaration;
13770 install its initial value.
13771 If the length of an array type is not known before,
13772 it must be determined now, from the initial value, or it is an error. */
13775 finish_decl (tree decl
, tree init
, bool is_top_level
)
13777 register tree type
= TREE_TYPE (decl
);
13778 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13779 bool at_top_level
= (current_binding_level
== global_binding_level
);
13780 bool top_level
= is_top_level
|| at_top_level
;
13782 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13784 assert (!is_top_level
|| !at_top_level
);
13786 if (TREE_CODE (decl
) == PARM_DECL
)
13787 assert (init
== NULL_TREE
);
13788 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13789 overlaps DECL_ARG_TYPE. */
13790 else if (init
== NULL_TREE
)
13791 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13793 assert (DECL_INITIAL (decl
) == error_mark_node
);
13795 if (init
!= NULL_TREE
)
13797 if (TREE_CODE (decl
) != TYPE_DECL
)
13798 DECL_INITIAL (decl
) = init
;
13801 /* typedef foo = bar; store the type of bar as the type of foo. */
13802 TREE_TYPE (decl
) = TREE_TYPE (init
);
13803 DECL_INITIAL (decl
) = init
= 0;
13807 /* Deduce size of array from initialization, if not already known */
13809 if (TREE_CODE (type
) == ARRAY_TYPE
13810 && TYPE_DOMAIN (type
) == 0
13811 && TREE_CODE (decl
) != TYPE_DECL
)
13813 assert (top_level
);
13814 assert (was_incomplete
);
13816 layout_decl (decl
, 0);
13819 if (TREE_CODE (decl
) == VAR_DECL
)
13821 if (DECL_SIZE (decl
) == NULL_TREE
13822 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13823 layout_decl (decl
, 0);
13825 if (DECL_SIZE (decl
) == NULL_TREE
13826 && (TREE_STATIC (decl
)
13828 /* A static variable with an incomplete type is an error if it is
13829 initialized. Also if it is not file scope. Otherwise, let it
13830 through, but if it is not `extern' then it may cause an error
13832 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13834 /* An automatic variable with an incomplete type is an error. */
13835 !DECL_EXTERNAL (decl
)))
13837 assert ("storage size not known" == NULL
);
13841 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13842 && (DECL_SIZE (decl
) != 0)
13843 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13845 assert ("storage size not constant" == NULL
);
13850 /* Output the assembler code and/or RTL code for variables and functions,
13851 unless the type is an undefined structure or union. If not, it will get
13852 done when the type is completed. */
13854 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13856 rest_of_decl_compilation (decl
, NULL
,
13857 DECL_CONTEXT (decl
) == 0,
13860 if (DECL_CONTEXT (decl
) != 0)
13862 /* Recompute the RTL of a local array now if it used to be an
13863 incomplete type. */
13865 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13867 /* If we used it already as memory, it must stay in memory. */
13868 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13869 /* If it's still incomplete now, no init will save it. */
13870 if (DECL_SIZE (decl
) == 0)
13871 DECL_INITIAL (decl
) = 0;
13872 expand_decl (decl
);
13874 /* Compute and store the initial value. */
13875 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13876 expand_decl_init (decl
);
13879 else if (TREE_CODE (decl
) == TYPE_DECL
)
13881 rest_of_decl_compilation (decl
, NULL_PTR
,
13882 DECL_CONTEXT (decl
) == 0,
13886 /* At the end of a declaration, throw away any variable type sizes of types
13887 defined inside that declaration. There is no use computing them in the
13888 following function definition. */
13889 if (current_binding_level
== global_binding_level
)
13890 get_pending_sizes ();
13893 /* Finish up a function declaration and compile that function
13894 all the way to assembler language output. The free the storage
13895 for the function definition.
13897 This is called after parsing the body of the function definition.
13899 NESTED is nonzero if the function being finished is nested in another. */
13902 finish_function (int nested
)
13904 register tree fndecl
= current_function_decl
;
13906 assert (fndecl
!= NULL_TREE
);
13907 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13910 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13912 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13915 /* TREE_READONLY (fndecl) = 1;
13916 This caused &foo to be of type ptr-to-const-function
13917 which then got a warning when stored in a ptr-to-function variable. */
13919 poplevel (1, 0, 1);
13921 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13923 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13925 /* Must mark the RESULT_DECL as being in this function. */
13927 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13929 /* Obey `register' declarations if `setjmp' is called in this fn. */
13930 /* Generate rtl for function exit. */
13931 expand_function_end (input_filename
, lineno
, 0);
13933 /* If this is a nested function, protect the local variables in the stack
13934 above us from being collected while we're compiling this function. */
13936 ggc_push_context ();
13938 /* Run the optimizers and output the assembler code for this function. */
13939 rest_of_compilation (fndecl
);
13941 /* Undo the GC context switch. */
13943 ggc_pop_context ();
13946 if (TREE_CODE (fndecl
) != ERROR_MARK
13948 && DECL_SAVED_INSNS (fndecl
) == 0)
13950 /* Stop pointing to the local nodes about to be freed. */
13951 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13952 function definition. */
13953 /* For a nested function, this is done in pop_f_function_context. */
13954 /* If rest_of_compilation set this to 0, leave it 0. */
13955 if (DECL_INITIAL (fndecl
) != 0)
13956 DECL_INITIAL (fndecl
) = error_mark_node
;
13957 DECL_ARGUMENTS (fndecl
) = 0;
13962 /* Let the error reporting routines know that we're outside a function.
13963 For a nested function, this value is used in pop_c_function_context
13964 and then reset via pop_function_context. */
13965 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13969 /* Plug-in replacement for identifying the name of a decl and, for a
13970 function, what we call it in diagnostics. For now, "program unit"
13971 should suffice, since it's a bit of a hassle to figure out which
13972 of several kinds of things it is. Note that it could conceivably
13973 be a statement function, which probably isn't really a program unit
13974 per se, but if that comes up, it should be easy to check (being a
13975 nested function and all). */
13977 static const char *
13978 lang_printable_name (tree decl
, int v
)
13980 /* Just to keep GCC quiet about the unused variable.
13981 In theory, differing values of V should produce different
13986 if (TREE_CODE (decl
) == ERROR_MARK
)
13987 return "erroneous code";
13988 return IDENTIFIER_POINTER (DECL_NAME (decl
));
13992 /* g77's function to print out name of current function that caused
13997 lang_print_error_function (const char *file
)
13999 static ffeglobal last_g
= NULL
;
14000 static ffesymbol last_s
= NULL
;
14005 if ((ffecom_primary_entry_
== NULL
)
14006 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14014 g
= ffesymbol_global (ffecom_primary_entry_
);
14015 if (ffecom_nested_entry_
== NULL
)
14017 s
= ffecom_primary_entry_
;
14018 switch (ffesymbol_kind (s
))
14020 case FFEINFO_kindFUNCTION
:
14024 case FFEINFO_kindSUBROUTINE
:
14025 kind
= "subroutine";
14028 case FFEINFO_kindPROGRAM
:
14032 case FFEINFO_kindBLOCKDATA
:
14033 kind
= "block-data";
14037 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14043 s
= ffecom_nested_entry_
;
14044 kind
= "statement function";
14048 if ((last_g
!= g
) || (last_s
!= s
))
14051 fprintf (stderr
, "%s: ", file
);
14054 fprintf (stderr
, "Outside of any program unit:\n");
14057 const char *name
= ffesymbol_text (s
);
14059 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14068 /* Similar to `lookup_name' but look only at current binding level. */
14071 lookup_name_current_level (tree name
)
14075 if (current_binding_level
== global_binding_level
)
14076 return IDENTIFIER_GLOBAL_VALUE (name
);
14078 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14081 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14082 if (DECL_NAME (t
) == name
)
14088 /* Create a new `struct binding_level'. */
14090 static struct binding_level
*
14091 make_binding_level ()
14094 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14097 /* Save and restore the variables in this file and elsewhere
14098 that keep track of the progress of compilation of the current function.
14099 Used for nested functions. */
14103 struct f_function
*next
;
14105 tree shadowed_labels
;
14106 struct binding_level
*binding_level
;
14109 struct f_function
*f_function_chain
;
14111 /* Restore the variables used during compilation of a C function. */
14114 pop_f_function_context ()
14116 struct f_function
*p
= f_function_chain
;
14119 /* Bring back all the labels that were shadowed. */
14120 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14121 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14122 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14123 = TREE_VALUE (link
);
14125 if (current_function_decl
!= error_mark_node
14126 && DECL_SAVED_INSNS (current_function_decl
) == 0)
14128 /* Stop pointing to the local nodes about to be freed. */
14129 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14130 function definition. */
14131 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14132 DECL_ARGUMENTS (current_function_decl
) = 0;
14135 pop_function_context ();
14137 f_function_chain
= p
->next
;
14139 named_labels
= p
->named_labels
;
14140 shadowed_labels
= p
->shadowed_labels
;
14141 current_binding_level
= p
->binding_level
;
14146 /* Save and reinitialize the variables
14147 used during compilation of a C function. */
14150 push_f_function_context ()
14152 struct f_function
*p
14153 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14155 push_function_context ();
14157 p
->next
= f_function_chain
;
14158 f_function_chain
= p
;
14160 p
->named_labels
= named_labels
;
14161 p
->shadowed_labels
= shadowed_labels
;
14162 p
->binding_level
= current_binding_level
;
14166 push_parm_decl (tree parm
)
14168 int old_immediate_size_expand
= immediate_size_expand
;
14170 /* Don't try computing parm sizes now -- wait till fn is called. */
14172 immediate_size_expand
= 0;
14174 /* Fill in arg stuff. */
14176 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14177 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14178 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14180 parm
= pushdecl (parm
);
14182 immediate_size_expand
= old_immediate_size_expand
;
14184 finish_decl (parm
, NULL_TREE
, FALSE
);
14187 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14190 pushdecl_top_level (x
)
14194 register struct binding_level
*b
= current_binding_level
;
14195 register tree f
= current_function_decl
;
14197 current_binding_level
= global_binding_level
;
14198 current_function_decl
= NULL_TREE
;
14200 current_binding_level
= b
;
14201 current_function_decl
= f
;
14205 /* Store the list of declarations of the current level.
14206 This is done for the parameter declarations of a function being defined,
14207 after they are modified in the light of any missing parameters. */
14213 return current_binding_level
->names
= decls
;
14216 /* Store the parameter declarations into the current function declaration.
14217 This is called after parsing the parameter declarations, before
14218 digesting the body of the function.
14220 For an old-style definition, modify the function's type
14221 to specify at least the number of arguments. */
14224 store_parm_decls (int is_main_program UNUSED
)
14226 register tree fndecl
= current_function_decl
;
14228 if (fndecl
== error_mark_node
)
14231 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14232 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14234 /* Initialize the RTL code for the function. */
14236 init_function_start (fndecl
, input_filename
, lineno
);
14238 /* Set up parameters and prepare for return, for the function. */
14240 expand_function_start (fndecl
, 0);
14244 start_decl (tree decl
, bool is_top_level
)
14247 bool at_top_level
= (current_binding_level
== global_binding_level
);
14248 bool top_level
= is_top_level
|| at_top_level
;
14250 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14252 assert (!is_top_level
|| !at_top_level
);
14254 if (DECL_INITIAL (decl
) != NULL_TREE
)
14256 assert (DECL_INITIAL (decl
) == error_mark_node
);
14257 assert (!DECL_EXTERNAL (decl
));
14259 else if (top_level
)
14260 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14262 /* For Fortran, we by default put things in .common when possible. */
14263 DECL_COMMON (decl
) = 1;
14265 /* Add this decl to the current binding level. TEM may equal DECL or it may
14266 be a previous decl of the same name. */
14268 tem
= pushdecl_top_level (decl
);
14270 tem
= pushdecl (decl
);
14272 /* For a local variable, define the RTL now. */
14274 /* But not if this is a duplicate decl and we preserved the rtl from the
14275 previous one (which may or may not happen). */
14276 && !DECL_RTL_SET_P (tem
))
14278 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14280 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14281 && DECL_INITIAL (tem
) != 0)
14288 /* Create the FUNCTION_DECL for a function definition.
14289 DECLSPECS and DECLARATOR are the parts of the declaration;
14290 they describe the function's name and the type it returns,
14291 but twisted together in a fashion that parallels the syntax of C.
14293 This function creates a binding context for the function body
14294 as well as setting up the FUNCTION_DECL in current_function_decl.
14296 Returns 1 on success. If the DECLARATOR is not suitable for a function
14297 (it defines a datum instead), we return 0, which tells
14298 yyparse to report a parse error.
14300 NESTED is nonzero for a function nested within another function. */
14303 start_function (tree name
, tree type
, int nested
, int public)
14307 int old_immediate_size_expand
= immediate_size_expand
;
14310 shadowed_labels
= 0;
14312 /* Don't expand any sizes in the return type of the function. */
14313 immediate_size_expand
= 0;
14318 assert (current_function_decl
!= NULL_TREE
);
14319 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14323 assert (current_function_decl
== NULL_TREE
);
14326 if (TREE_CODE (type
) == ERROR_MARK
)
14327 decl1
= current_function_decl
= error_mark_node
;
14330 decl1
= build_decl (FUNCTION_DECL
,
14333 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14335 DECL_INLINE (decl1
) = 1;
14336 TREE_STATIC (decl1
) = 1;
14337 DECL_EXTERNAL (decl1
) = 0;
14339 announce_function (decl1
);
14341 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14342 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14343 DECL_INITIAL (decl1
) = error_mark_node
;
14345 /* Record the decl so that the function name is defined. If we already have
14346 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14348 current_function_decl
= pushdecl (decl1
);
14352 ffecom_outer_function_decl_
= current_function_decl
;
14355 current_binding_level
->prep_state
= 2;
14357 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14359 make_decl_rtl (current_function_decl
, NULL
);
14361 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14362 DECL_RESULT (current_function_decl
)
14363 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14366 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14367 TREE_ADDRESSABLE (current_function_decl
) = 1;
14369 immediate_size_expand
= old_immediate_size_expand
;
14372 /* Here are the public functions the GNU back end needs. */
14375 convert (type
, expr
)
14378 register tree e
= expr
;
14379 register enum tree_code code
= TREE_CODE (type
);
14381 if (type
== TREE_TYPE (e
)
14382 || TREE_CODE (e
) == ERROR_MARK
)
14384 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14385 return fold (build1 (NOP_EXPR
, type
, e
));
14386 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14387 || code
== ERROR_MARK
)
14388 return error_mark_node
;
14389 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14391 assert ("void value not ignored as it ought to be" == NULL
);
14392 return error_mark_node
;
14394 if (code
== VOID_TYPE
)
14395 return build1 (CONVERT_EXPR
, type
, e
);
14396 if ((code
!= RECORD_TYPE
)
14397 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14398 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14400 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14401 return fold (convert_to_integer (type
, e
));
14402 if (code
== POINTER_TYPE
)
14403 return fold (convert_to_pointer (type
, e
));
14404 if (code
== REAL_TYPE
)
14405 return fold (convert_to_real (type
, e
));
14406 if (code
== COMPLEX_TYPE
)
14407 return fold (convert_to_complex (type
, e
));
14408 if (code
== RECORD_TYPE
)
14409 return fold (ffecom_convert_to_complex_ (type
, e
));
14411 assert ("conversion to non-scalar type requested" == NULL
);
14412 return error_mark_node
;
14415 /* integrate_decl_tree calls this function, but since we don't use the
14416 DECL_LANG_SPECIFIC field, this is a no-op. */
14419 copy_lang_decl (node
)
14424 /* Return the list of declarations of the current level.
14425 Note that this list is in reverse order unless/until
14426 you nreverse it; and when you do nreverse it, you must
14427 store the result back using `storedecls' or you will lose. */
14432 return current_binding_level
->names
;
14435 /* Nonzero if we are currently in the global binding level. */
14438 global_bindings_p ()
14440 return current_binding_level
== global_binding_level
;
14443 /* Print an error message for invalid use of an incomplete type.
14444 VALUE is the expression that was used (or 0 if that isn't known)
14445 and TYPE is the type that was invalid. */
14448 incomplete_type_error (value
, type
)
14452 if (TREE_CODE (type
) == ERROR_MARK
)
14455 assert ("incomplete type?!?" == NULL
);
14458 /* Mark ARG for GC. */
14460 mark_binding_level (void *arg
)
14462 struct binding_level
*level
= *(struct binding_level
**) arg
;
14466 ggc_mark_tree (level
->names
);
14467 ggc_mark_tree (level
->blocks
);
14468 ggc_mark_tree (level
->this_block
);
14469 level
= level
->level_chain
;
14474 init_decl_processing ()
14476 static tree
*const tree_roots
[] = {
14477 ¤t_function_decl
,
14479 &ffecom_tree_fun_type_void
,
14480 &ffecom_integer_zero_node
,
14481 &ffecom_integer_one_node
,
14482 &ffecom_tree_subr_type
,
14483 &ffecom_tree_ptr_to_subr_type
,
14484 &ffecom_tree_blockdata_type
,
14485 &ffecom_tree_xargc_
,
14486 &ffecom_f2c_integer_type_node
,
14487 &ffecom_f2c_ptr_to_integer_type_node
,
14488 &ffecom_f2c_address_type_node
,
14489 &ffecom_f2c_real_type_node
,
14490 &ffecom_f2c_ptr_to_real_type_node
,
14491 &ffecom_f2c_doublereal_type_node
,
14492 &ffecom_f2c_complex_type_node
,
14493 &ffecom_f2c_doublecomplex_type_node
,
14494 &ffecom_f2c_longint_type_node
,
14495 &ffecom_f2c_logical_type_node
,
14496 &ffecom_f2c_flag_type_node
,
14497 &ffecom_f2c_ftnlen_type_node
,
14498 &ffecom_f2c_ftnlen_zero_node
,
14499 &ffecom_f2c_ftnlen_one_node
,
14500 &ffecom_f2c_ftnlen_two_node
,
14501 &ffecom_f2c_ptr_to_ftnlen_type_node
,
14502 &ffecom_f2c_ftnint_type_node
,
14503 &ffecom_f2c_ptr_to_ftnint_type_node
,
14504 &ffecom_outer_function_decl_
,
14505 &ffecom_previous_function_decl_
,
14506 &ffecom_which_entrypoint_decl_
,
14507 &ffecom_float_zero_
,
14508 &ffecom_float_half_
,
14509 &ffecom_double_zero_
,
14510 &ffecom_double_half_
,
14511 &ffecom_func_result_
,
14512 &ffecom_func_length_
,
14513 &ffecom_multi_type_node_
,
14514 &ffecom_multi_retval_
,
14522 /* Record our roots. */
14523 for (i
= 0; i
< ARRAY_SIZE (tree_roots
); i
++)
14524 ggc_add_tree_root (tree_roots
[i
], 1);
14525 ggc_add_tree_root (&ffecom_tree_type
[0][0],
14526 FFEINFO_basictype
*FFEINFO_kindtype
);
14527 ggc_add_tree_root (&ffecom_tree_fun_type
[0][0],
14528 FFEINFO_basictype
*FFEINFO_kindtype
);
14529 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type
[0][0],
14530 FFEINFO_basictype
*FFEINFO_kindtype
);
14531 ggc_add_tree_root (ffecom_gfrt_
, FFECOM_gfrt
);
14532 ggc_add_root (¤t_binding_level
, 1, sizeof current_binding_level
,
14533 mark_binding_level
);
14534 ggc_add_root (&free_binding_level
, 1, sizeof current_binding_level
,
14535 mark_binding_level
);
14536 ggc_add_root (&tracker_head
, 1, sizeof tracker_head
, mark_tracker_head
);
14542 init_parse (filename
)
14543 const char *filename
;
14545 /* Open input file. */
14546 if (filename
== 0 || !strcmp (filename
, "-"))
14549 filename
= "stdin";
14552 finput
= fopen (filename
, "r");
14554 fatal_io_error ("can't open %s", filename
);
14556 #ifdef IO_BUFFER_SIZE
14557 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14560 /* Make identifier nodes long enough for the language-specific slots. */
14561 set_identifier_size (sizeof (struct lang_identifier
));
14562 decl_printable_name
= lang_printable_name
;
14564 print_error_function
= lang_print_error_function
;
14576 /* Delete the node BLOCK from the current binding level.
14577 This is used for the block inside a stmt expr ({...})
14578 so that the block can be reinserted where appropriate. */
14581 delete_block (block
)
14585 if (current_binding_level
->blocks
== block
)
14586 current_binding_level
->blocks
= TREE_CHAIN (block
);
14587 for (t
= current_binding_level
->blocks
; t
;)
14589 if (TREE_CHAIN (t
) == block
)
14590 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14592 t
= TREE_CHAIN (t
);
14594 TREE_CHAIN (block
) = NULL
;
14595 /* Clear TREE_USED which is always set by poplevel.
14596 The flag is set again if insert_block is called. */
14597 TREE_USED (block
) = 0;
14601 insert_block (block
)
14604 TREE_USED (block
) = 1;
14605 current_binding_level
->blocks
14606 = chainon (current_binding_level
->blocks
, block
);
14609 /* Each front end provides its own. */
14610 static void ffe_init
PARAMS ((void));
14611 static void ffe_finish
PARAMS ((void));
14612 static void ffe_init_options
PARAMS ((void));
14614 struct lang_hooks lang_hooks
= {ffe_init
,
14618 NULL
/* post_options */};
14620 /* used by print-tree.c */
14623 lang_print_xnode (file
, node
, indent
)
14633 ffe_terminate_0 ();
14635 if (ffe_is_ffedebug ())
14636 malloc_pool_display (malloc_pool_image ());
14645 /* Return the typed-based alias set for T, which may be an expression
14646 or a type. Return -1 if we don't do anything special. */
14649 lang_get_alias_set (t
)
14650 tree t ATTRIBUTE_UNUSED
;
14652 /* We do not wish to use alias-set based aliasing at all. Used in the
14653 extreme (every object with its own set, with equivalences recorded)
14654 it might be helpful, but there are problems when it comes to inlining.
14655 We get on ok with flag_argument_noalias, and alias-set aliasing does
14656 currently limit how stack slots can be reused, which is a lose. */
14661 ffe_init_options ()
14663 /* Set default options for Fortran. */
14664 flag_move_all_movables
= 1;
14665 flag_reduce_all_givs
= 1;
14666 flag_argument_noalias
= 2;
14667 flag_errno_math
= 0;
14668 flag_complex_divide_method
= 1;
14674 /* If the file is output from cpp, it should contain a first line
14675 `# 1 "real-filename"', and the current design of gcc (toplev.c
14676 in particular and the way it sets up information relied on by
14677 INCLUDE) requires that we read this now, and store the
14678 "real-filename" info in master_input_filename. Ask the lexer
14679 to try doing this. */
14680 ffelex_hash_kludge (finput
);
14684 mark_addressable (exp
)
14687 register tree x
= exp
;
14689 switch (TREE_CODE (x
))
14692 case COMPONENT_REF
:
14694 x
= TREE_OPERAND (x
, 0);
14698 TREE_ADDRESSABLE (x
) = 1;
14705 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14706 && DECL_NONLOCAL (x
))
14708 if (TREE_PUBLIC (x
))
14710 assert ("address of global register var requested" == NULL
);
14713 assert ("address of register variable requested" == NULL
);
14715 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14717 if (TREE_PUBLIC (x
))
14719 assert ("address of global register var requested" == NULL
);
14722 assert ("address of register var requested" == NULL
);
14724 put_var_into_stack (x
);
14727 case FUNCTION_DECL
:
14728 TREE_ADDRESSABLE (x
) = 1;
14729 #if 0 /* poplevel deals with this now. */
14730 if (DECL_CONTEXT (x
) == 0)
14731 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14739 /* If DECL has a cleanup, build and return that cleanup here.
14740 This is a callback called by expand_expr. */
14743 maybe_build_cleanup (decl
)
14746 /* There are no cleanups in Fortran. */
14750 /* Exit a binding level.
14751 Pop the level off, and restore the state of the identifier-decl mappings
14752 that were in effect when this level was entered.
14754 If KEEP is nonzero, this level had explicit declarations, so
14755 and create a "block" (a BLOCK node) for the level
14756 to record its declarations and subblocks for symbol table output.
14758 If FUNCTIONBODY is nonzero, this level is the body of a function,
14759 so create a block as if KEEP were set and also clear out all
14762 If REVERSE is nonzero, reverse the order of decls before putting
14763 them into the BLOCK. */
14766 poplevel (keep
, reverse
, functionbody
)
14771 register tree link
;
14772 /* The chain of decls was accumulated in reverse order.
14773 Put it into forward order, just for cleanliness. */
14775 tree subblocks
= current_binding_level
->blocks
;
14778 int block_previously_created
;
14780 /* Get the decls in the order they were written.
14781 Usually current_binding_level->names is in reverse order.
14782 But parameter decls were previously put in forward order. */
14785 current_binding_level
->names
14786 = decls
= nreverse (current_binding_level
->names
);
14788 decls
= current_binding_level
->names
;
14790 /* Output any nested inline functions within this block
14791 if they weren't already output. */
14793 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14794 if (TREE_CODE (decl
) == FUNCTION_DECL
14795 && ! TREE_ASM_WRITTEN (decl
)
14796 && DECL_INITIAL (decl
) != 0
14797 && TREE_ADDRESSABLE (decl
))
14799 /* If this decl was copied from a file-scope decl
14800 on account of a block-scope extern decl,
14801 propagate TREE_ADDRESSABLE to the file-scope decl.
14803 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14804 true, since then the decl goes through save_for_inline_copying. */
14805 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14806 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14807 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14808 else if (DECL_SAVED_INSNS (decl
) != 0)
14810 push_function_context ();
14811 output_inline_function (decl
);
14812 pop_function_context ();
14816 /* If there were any declarations or structure tags in that level,
14817 or if this level is a function body,
14818 create a BLOCK to record them for the life of this function. */
14821 block_previously_created
= (current_binding_level
->this_block
!= 0);
14822 if (block_previously_created
)
14823 block
= current_binding_level
->this_block
;
14824 else if (keep
|| functionbody
)
14825 block
= make_node (BLOCK
);
14828 BLOCK_VARS (block
) = decls
;
14829 BLOCK_SUBBLOCKS (block
) = subblocks
;
14832 /* In each subblock, record that this is its superior. */
14834 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14835 BLOCK_SUPERCONTEXT (link
) = block
;
14837 /* Clear out the meanings of the local variables of this level. */
14839 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14841 if (DECL_NAME (link
) != 0)
14843 /* If the ident. was used or addressed via a local extern decl,
14844 don't forget that fact. */
14845 if (DECL_EXTERNAL (link
))
14847 if (TREE_USED (link
))
14848 TREE_USED (DECL_NAME (link
)) = 1;
14849 if (TREE_ADDRESSABLE (link
))
14850 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14852 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14856 /* If the level being exited is the top level of a function,
14857 check over all the labels, and clear out the current
14858 (function local) meanings of their names. */
14862 /* If this is the top level block of a function,
14863 the vars are the function's parameters.
14864 Don't leave them in the BLOCK because they are
14865 found in the FUNCTION_DECL instead. */
14867 BLOCK_VARS (block
) = 0;
14870 /* Pop the current level, and free the structure for reuse. */
14873 register struct binding_level
*level
= current_binding_level
;
14874 current_binding_level
= current_binding_level
->level_chain
;
14876 level
->level_chain
= free_binding_level
;
14877 free_binding_level
= level
;
14880 /* Dispose of the block that we just made inside some higher level. */
14882 && current_function_decl
!= error_mark_node
)
14883 DECL_INITIAL (current_function_decl
) = block
;
14886 if (!block_previously_created
)
14887 current_binding_level
->blocks
14888 = chainon (current_binding_level
->blocks
, block
);
14890 /* If we did not make a block for the level just exited,
14891 any blocks made for inner levels
14892 (since they cannot be recorded as subblocks in that level)
14893 must be carried forward so they will later become subblocks
14894 of something else. */
14895 else if (subblocks
)
14896 current_binding_level
->blocks
14897 = chainon (current_binding_level
->blocks
, subblocks
);
14900 TREE_USED (block
) = 1;
14905 print_lang_decl (file
, node
, indent
)
14913 print_lang_identifier (file
, node
, indent
)
14918 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14919 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14923 print_lang_statistics ()
14928 print_lang_type (file
, node
, indent
)
14935 /* Record a decl-node X as belonging to the current lexical scope.
14936 Check for errors (such as an incompatible declaration for the same
14937 name already seen in the same scope).
14939 Returns either X or an old decl for the same name.
14940 If an old decl is returned, it may have been smashed
14941 to agree with what X says. */
14948 register tree name
= DECL_NAME (x
);
14949 register struct binding_level
*b
= current_binding_level
;
14951 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14952 && (DECL_INITIAL (x
) == 0)
14953 && DECL_EXTERNAL (x
))
14954 DECL_CONTEXT (x
) = NULL_TREE
;
14956 DECL_CONTEXT (x
) = current_function_decl
;
14960 if (IDENTIFIER_INVENTED (name
))
14963 DECL_ARTIFICIAL (x
) = 1;
14965 DECL_IN_SYSTEM_HEADER (x
) = 1;
14968 t
= lookup_name_current_level (name
);
14970 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14972 /* Don't push non-parms onto list for parms until we understand
14973 why we're doing this and whether it works. */
14975 assert ((b
== global_binding_level
)
14976 || !ffecom_transform_only_dummies_
14977 || TREE_CODE (x
) == PARM_DECL
);
14979 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
14982 /* If we are processing a typedef statement, generate a whole new
14983 ..._TYPE node (which will be just an variant of the existing
14984 ..._TYPE node with identical properties) and then install the
14985 TYPE_DECL node generated to represent the typedef name as the
14986 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14988 The whole point here is to end up with a situation where each and every
14989 ..._TYPE node the compiler creates will be uniquely associated with
14990 AT MOST one node representing a typedef name. This way, even though
14991 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14992 (i.e. "typedef name") nodes very early on, later parts of the
14993 compiler can always do the reverse translation and get back the
14994 corresponding typedef name. For example, given:
14996 typedef struct S MY_TYPE; MY_TYPE object;
14998 Later parts of the compiler might only know that `object' was of type
14999 `struct S' if it were not for code just below. With this code
15000 however, later parts of the compiler see something like:
15002 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15004 And they can then deduce (from the node for type struct S') that the
15005 original object declaration was:
15009 Being able to do this is important for proper support of protoize, and
15010 also for generating precise symbolic debugging information which
15011 takes full account of the programmer's (typedef) vocabulary.
15013 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15014 TYPE_DECL node that we are now processing really represents a
15015 standard built-in type.
15017 Since all standard types are effectively declared at line zero in the
15018 source file, we can easily check to see if we are working on a
15019 standard type by checking the current value of lineno. */
15021 if (TREE_CODE (x
) == TYPE_DECL
)
15023 if (DECL_SOURCE_LINE (x
) == 0)
15025 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15026 TYPE_NAME (TREE_TYPE (x
)) = x
;
15028 else if (TREE_TYPE (x
) != error_mark_node
)
15030 tree tt
= TREE_TYPE (x
);
15032 tt
= build_type_copy (tt
);
15033 TYPE_NAME (tt
) = x
;
15034 TREE_TYPE (x
) = tt
;
15038 /* This name is new in its binding level. Install the new declaration
15040 if (b
== global_binding_level
)
15041 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15043 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15046 /* Put decls on list in reverse order. We will reverse them later if
15048 TREE_CHAIN (x
) = b
->names
;
15054 /* Nonzero if the current level needs to have a BLOCK made. */
15061 for (decl
= current_binding_level
->names
;
15063 decl
= TREE_CHAIN (decl
))
15065 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
15066 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
15067 /* Currently, there aren't supposed to be non-artificial names
15068 at other than the top block for a function -- they're
15069 believed to always be temps. But it's wise to check anyway. */
15075 /* Enter a new binding level.
15076 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15077 not for that of tags. */
15080 pushlevel (tag_transparent
)
15081 int tag_transparent
;
15083 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15085 assert (! tag_transparent
);
15087 if (current_binding_level
== global_binding_level
)
15092 /* Reuse or create a struct for this binding level. */
15094 if (free_binding_level
)
15096 newlevel
= free_binding_level
;
15097 free_binding_level
= free_binding_level
->level_chain
;
15101 newlevel
= make_binding_level ();
15104 /* Add this level to the front of the chain (stack) of levels that
15107 *newlevel
= clear_binding_level
;
15108 newlevel
->level_chain
= current_binding_level
;
15109 current_binding_level
= newlevel
;
15112 /* Set the BLOCK node for the innermost scope
15113 (the one we are currently in). */
15117 register tree block
;
15119 current_binding_level
->this_block
= block
;
15120 current_binding_level
->names
= chainon (current_binding_level
->names
,
15121 BLOCK_VARS (block
));
15122 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
15123 BLOCK_SUBBLOCKS (block
));
15126 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15128 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15131 set_yydebug (value
)
15135 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15139 signed_or_unsigned_type (unsignedp
, type
)
15145 if (! INTEGRAL_TYPE_P (type
))
15147 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15148 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15149 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15150 return unsignedp
? unsigned_type_node
: integer_type_node
;
15151 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15152 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15153 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15154 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15155 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15156 return (unsignedp
? long_long_unsigned_type_node
15157 : long_long_integer_type_node
);
15159 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15160 if (type2
== NULL_TREE
)
15170 tree type1
= TYPE_MAIN_VARIANT (type
);
15171 ffeinfoKindtype kt
;
15174 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15175 return signed_char_type_node
;
15176 if (type1
== unsigned_type_node
)
15177 return integer_type_node
;
15178 if (type1
== short_unsigned_type_node
)
15179 return short_integer_type_node
;
15180 if (type1
== long_unsigned_type_node
)
15181 return long_integer_type_node
;
15182 if (type1
== long_long_unsigned_type_node
)
15183 return long_long_integer_type_node
;
15184 #if 0 /* gcc/c-* files only */
15185 if (type1
== unsigned_intDI_type_node
)
15186 return intDI_type_node
;
15187 if (type1
== unsigned_intSI_type_node
)
15188 return intSI_type_node
;
15189 if (type1
== unsigned_intHI_type_node
)
15190 return intHI_type_node
;
15191 if (type1
== unsigned_intQI_type_node
)
15192 return intQI_type_node
;
15195 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15196 if (type2
!= NULL_TREE
)
15199 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15201 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15203 if (type1
== type2
)
15204 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15210 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15211 or validate its data type for an `if' or `while' statement or ?..: exp.
15213 This preparation consists of taking the ordinary
15214 representation of an expression expr and producing a valid tree
15215 boolean expression describing whether expr is nonzero. We could
15216 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15217 but we optimize comparisons, &&, ||, and !.
15219 The resulting type should always be `integer_type_node'. */
15222 truthvalue_conversion (expr
)
15225 if (TREE_CODE (expr
) == ERROR_MARK
)
15228 #if 0 /* This appears to be wrong for C++. */
15229 /* These really should return error_mark_node after 2.4 is stable.
15230 But not all callers handle ERROR_MARK properly. */
15231 switch (TREE_CODE (TREE_TYPE (expr
)))
15234 error ("struct type value used where scalar is required");
15235 return integer_zero_node
;
15238 error ("union type value used where scalar is required");
15239 return integer_zero_node
;
15242 error ("array type value used where scalar is required");
15243 return integer_zero_node
;
15250 switch (TREE_CODE (expr
))
15252 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15253 or comparison expressions as truth values at this level. */
15255 case COMPONENT_REF
:
15256 /* A one-bit unsigned bit-field is already acceptable. */
15257 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15258 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15264 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15265 or comparison expressions as truth values at this level. */
15267 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15268 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15270 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15271 case TRUTH_ANDIF_EXPR
:
15272 case TRUTH_ORIF_EXPR
:
15273 case TRUTH_AND_EXPR
:
15274 case TRUTH_OR_EXPR
:
15275 case TRUTH_XOR_EXPR
:
15276 TREE_TYPE (expr
) = integer_type_node
;
15283 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15286 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15289 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15290 return build (COMPOUND_EXPR
, integer_type_node
,
15291 TREE_OPERAND (expr
, 0), integer_one_node
);
15293 return integer_one_node
;
15296 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15297 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15299 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15300 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15306 /* These don't change whether an object is non-zero or zero. */
15307 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15311 /* These don't change whether an object is zero or non-zero, but
15312 we can't ignore them if their second arg has side-effects. */
15313 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15314 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15315 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15317 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15320 /* Distribute the conversion into the arms of a COND_EXPR. */
15321 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15322 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15323 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15326 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15327 since that affects how `default_conversion' will behave. */
15328 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15329 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15331 /* fall through... */
15333 /* If this is widening the argument, we can ignore it. */
15334 if (TYPE_PRECISION (TREE_TYPE (expr
))
15335 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15336 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15340 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15342 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15343 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15345 /* fall through... */
15347 /* This and MINUS_EXPR can be changed into a comparison of the
15349 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15350 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15351 return ffecom_2 (NE_EXPR
, integer_type_node
,
15352 TREE_OPERAND (expr
, 0),
15353 TREE_OPERAND (expr
, 1));
15354 return ffecom_2 (NE_EXPR
, integer_type_node
,
15355 TREE_OPERAND (expr
, 0),
15356 fold (build1 (NOP_EXPR
,
15357 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15358 TREE_OPERAND (expr
, 1))));
15361 if (integer_onep (TREE_OPERAND (expr
, 1)))
15366 #if 0 /* No such thing in Fortran. */
15367 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15368 warning ("suggest parentheses around assignment used as truth value");
15376 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15378 ((TREE_SIDE_EFFECTS (expr
)
15379 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15381 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15382 TREE_TYPE (TREE_TYPE (expr
)),
15384 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15385 TREE_TYPE (TREE_TYPE (expr
)),
15388 return ffecom_2 (NE_EXPR
, integer_type_node
,
15390 convert (TREE_TYPE (expr
), integer_zero_node
));
15394 type_for_mode (mode
, unsignedp
)
15395 enum machine_mode mode
;
15402 if (mode
== TYPE_MODE (integer_type_node
))
15403 return unsignedp
? unsigned_type_node
: integer_type_node
;
15405 if (mode
== TYPE_MODE (signed_char_type_node
))
15406 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15408 if (mode
== TYPE_MODE (short_integer_type_node
))
15409 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15411 if (mode
== TYPE_MODE (long_integer_type_node
))
15412 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15414 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15415 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15417 #if HOST_BITS_PER_WIDE_INT >= 64
15418 if (mode
== TYPE_MODE (intTI_type_node
))
15419 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
15422 if (mode
== TYPE_MODE (float_type_node
))
15423 return float_type_node
;
15425 if (mode
== TYPE_MODE (double_type_node
))
15426 return double_type_node
;
15428 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15429 return build_pointer_type (char_type_node
);
15431 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15432 return build_pointer_type (integer_type_node
);
15434 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15435 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15437 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15438 && (mode
== TYPE_MODE (t
)))
15440 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15441 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15451 type_for_size (bits
, unsignedp
)
15455 ffeinfoKindtype kt
;
15458 if (bits
== TYPE_PRECISION (integer_type_node
))
15459 return unsignedp
? unsigned_type_node
: integer_type_node
;
15461 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15462 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15464 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15465 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15467 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15468 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15470 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15471 return (unsignedp
? long_long_unsigned_type_node
15472 : long_long_integer_type_node
);
15474 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15476 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15478 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15479 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15487 unsigned_type (type
)
15490 tree type1
= TYPE_MAIN_VARIANT (type
);
15491 ffeinfoKindtype kt
;
15494 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15495 return unsigned_char_type_node
;
15496 if (type1
== integer_type_node
)
15497 return unsigned_type_node
;
15498 if (type1
== short_integer_type_node
)
15499 return short_unsigned_type_node
;
15500 if (type1
== long_integer_type_node
)
15501 return long_unsigned_type_node
;
15502 if (type1
== long_long_integer_type_node
)
15503 return long_long_unsigned_type_node
;
15504 #if 0 /* gcc/c-* files only */
15505 if (type1
== intDI_type_node
)
15506 return unsigned_intDI_type_node
;
15507 if (type1
== intSI_type_node
)
15508 return unsigned_intSI_type_node
;
15509 if (type1
== intHI_type_node
)
15510 return unsigned_intHI_type_node
;
15511 if (type1
== intQI_type_node
)
15512 return unsigned_intQI_type_node
;
15515 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15516 if (type2
!= NULL_TREE
)
15519 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15521 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15523 if (type1
== type2
)
15524 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15532 union tree_node
*t ATTRIBUTE_UNUSED
;
15534 if (TREE_CODE (t
) == IDENTIFIER_NODE
)
15536 struct lang_identifier
*i
= (struct lang_identifier
*) t
;
15537 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i
));
15538 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i
));
15539 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i
));
15541 else if (TYPE_P (t
) && TYPE_LANG_SPECIFIC (t
))
15542 ggc_mark (TYPE_LANG_SPECIFIC (t
));
15545 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15547 #if FFECOM_GCC_INCLUDE
15549 /* From gcc/cccp.c, the code to handle -I. */
15551 /* Skip leading "./" from a directory name.
15552 This may yield the empty string, which represents the current directory. */
15554 static const char *
15555 skip_redundant_dir_prefix (const char *dir
)
15557 while (dir
[0] == '.' && dir
[1] == '/')
15558 for (dir
+= 2; *dir
== '/'; dir
++)
15560 if (dir
[0] == '.' && !dir
[1])
15565 /* The file_name_map structure holds a mapping of file names for a
15566 particular directory. This mapping is read from the file named
15567 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15568 map filenames on a file system with severe filename restrictions,
15569 such as DOS. The format of the file name map file is just a series
15570 of lines with two tokens on each line. The first token is the name
15571 to map, and the second token is the actual name to use. */
15573 struct file_name_map
15575 struct file_name_map
*map_next
;
15580 #define FILE_NAME_MAP_FILE "header.gcc"
15582 /* Current maximum length of directory names in the search path
15583 for include files. (Altered as we get more of them.) */
15585 static int max_include_len
= 0;
15587 struct file_name_list
15589 struct file_name_list
*next
;
15591 /* Mapping of file names for this directory. */
15592 struct file_name_map
*name_map
;
15593 /* Non-zero if name_map is valid. */
15597 static struct file_name_list
*include
= NULL
; /* First dir to search */
15598 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15600 /* I/O buffer structure.
15601 The `fname' field is nonzero for source files and #include files
15602 and for the dummy text used for -D and -U.
15603 It is zero for rescanning results of macro expansion
15604 and for expanding macro arguments. */
15605 #define INPUT_STACK_MAX 400
15606 static struct file_buf
{
15608 /* Filename specified with #line command. */
15609 const char *nominal_fname
;
15610 /* Record where in the search path this file was found.
15611 For #include_next. */
15612 struct file_name_list
*dir
;
15614 ffewhereColumn column
;
15615 } instack
[INPUT_STACK_MAX
];
15617 static int last_error_tick
= 0; /* Incremented each time we print it. */
15618 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15620 /* Current nesting level of input sources.
15621 `instack[indepth]' is the level currently being read. */
15622 static int indepth
= -1;
15624 typedef struct file_buf FILE_BUF
;
15626 typedef unsigned char U_CHAR
;
15628 /* table to tell if char can be part of a C identifier. */
15629 U_CHAR is_idchar
[256];
15630 /* table to tell if char can be first char of a c identifier. */
15631 U_CHAR is_idstart
[256];
15632 /* table to tell if c is horizontal space. */
15633 U_CHAR is_hor_space
[256];
15634 /* table to tell if c is horizontal or vertical space. */
15635 static U_CHAR is_space
[256];
15637 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15638 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15640 /* Nonzero means -I- has been seen,
15641 so don't look for #include "foo" the source-file directory. */
15642 static int ignore_srcdir
;
15644 #ifndef INCLUDE_LEN_FUDGE
15645 #define INCLUDE_LEN_FUDGE 0
15648 static void append_include_chain (struct file_name_list
*first
,
15649 struct file_name_list
*last
);
15650 static FILE *open_include_file (char *filename
,
15651 struct file_name_list
*searchptr
);
15652 static void print_containing_files (ffebadSeverity sev
);
15653 static const char *skip_redundant_dir_prefix (const char *);
15654 static char *read_filename_string (int ch
, FILE *f
);
15655 static struct file_name_map
*read_name_map (const char *dirname
);
15657 /* Append a chain of `struct file_name_list's
15658 to the end of the main include chain.
15659 FIRST is the beginning of the chain to append, and LAST is the end. */
15662 append_include_chain (first
, last
)
15663 struct file_name_list
*first
, *last
;
15665 struct file_name_list
*dir
;
15667 if (!first
|| !last
)
15673 last_include
->next
= first
;
15675 for (dir
= first
; ; dir
= dir
->next
) {
15676 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15677 if (len
> max_include_len
)
15678 max_include_len
= len
;
15684 last_include
= last
;
15687 /* Try to open include file FILENAME. SEARCHPTR is the directory
15688 being tried from the include file search path. This function maps
15689 filenames on file systems based on information read by
15693 open_include_file (filename
, searchptr
)
15695 struct file_name_list
*searchptr
;
15697 register struct file_name_map
*map
;
15698 register char *from
;
15701 if (searchptr
&& ! searchptr
->got_name_map
)
15703 searchptr
->name_map
= read_name_map (searchptr
->fname
15704 ? searchptr
->fname
: ".");
15705 searchptr
->got_name_map
= 1;
15708 /* First check the mapping for the directory we are using. */
15709 if (searchptr
&& searchptr
->name_map
)
15712 if (searchptr
->fname
)
15713 from
+= strlen (searchptr
->fname
) + 1;
15714 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15716 if (! strcmp (map
->map_from
, from
))
15718 /* Found a match. */
15719 return fopen (map
->map_to
, "r");
15724 /* Try to find a mapping file for the particular directory we are
15725 looking in. Thus #include <sys/types.h> will look up sys/types.h
15726 in /usr/include/header.gcc and look up types.h in
15727 /usr/include/sys/header.gcc. */
15728 p
= strrchr (filename
, '/');
15729 #ifdef DIR_SEPARATOR
15730 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15732 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15733 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15739 && searchptr
->fname
15740 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15741 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15743 /* FILENAME is in SEARCHPTR, which we've already checked. */
15744 return fopen (filename
, "r");
15750 map
= read_name_map (".");
15754 dir
= (char *) xmalloc (p
- filename
+ 1);
15755 memcpy (dir
, filename
, p
- filename
);
15756 dir
[p
- filename
] = '\0';
15758 map
= read_name_map (dir
);
15761 for (; map
; map
= map
->map_next
)
15762 if (! strcmp (map
->map_from
, from
))
15763 return fopen (map
->map_to
, "r");
15765 return fopen (filename
, "r");
15768 /* Print the file names and line numbers of the #include
15769 commands which led to the current file. */
15772 print_containing_files (ffebadSeverity sev
)
15774 FILE_BUF
*ip
= NULL
;
15780 /* If stack of files hasn't changed since we last printed
15781 this info, don't repeat it. */
15782 if (last_error_tick
== input_file_stack_tick
)
15785 for (i
= indepth
; i
>= 0; i
--)
15786 if (instack
[i
].fname
!= NULL
) {
15791 /* Give up if we don't find a source file. */
15795 /* Find the other, outer source files. */
15796 for (i
--; i
>= 0; i
--)
15797 if (instack
[i
].fname
!= NULL
)
15803 str1
= "In file included";
15815 ffebad_start_msg ("%A from %B at %0%C", sev
);
15816 ffebad_here (0, ip
->line
, ip
->column
);
15817 ffebad_string (str1
);
15818 ffebad_string (ip
->nominal_fname
);
15819 ffebad_string (str2
);
15823 /* Record we have printed the status as of this time. */
15824 last_error_tick
= input_file_stack_tick
;
15827 /* Read a space delimited string of unlimited length from a stdio
15831 read_filename_string (ch
, f
)
15839 set
= alloc
= xmalloc (len
+ 1);
15840 if (! is_space
[ch
])
15843 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
15845 if (set
- alloc
== len
)
15848 alloc
= xrealloc (alloc
, len
+ 1);
15849 set
= alloc
+ len
/ 2;
15859 /* Read the file name map file for DIRNAME. */
15861 static struct file_name_map
*
15862 read_name_map (dirname
)
15863 const char *dirname
;
15865 /* This structure holds a linked list of file name maps, one per
15867 struct file_name_map_list
15869 struct file_name_map_list
*map_list_next
;
15870 char *map_list_name
;
15871 struct file_name_map
*map_list_map
;
15873 static struct file_name_map_list
*map_list
;
15874 register struct file_name_map_list
*map_list_ptr
;
15878 int separator_needed
;
15880 dirname
= skip_redundant_dir_prefix (dirname
);
15882 for (map_list_ptr
= map_list
; map_list_ptr
;
15883 map_list_ptr
= map_list_ptr
->map_list_next
)
15884 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15885 return map_list_ptr
->map_list_map
;
15887 map_list_ptr
= ((struct file_name_map_list
*)
15888 xmalloc (sizeof (struct file_name_map_list
)));
15889 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15890 map_list_ptr
->map_list_map
= NULL
;
15892 dirlen
= strlen (dirname
);
15893 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15894 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
15895 strcpy (name
, dirname
);
15896 name
[dirlen
] = '/';
15897 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
15898 f
= fopen (name
, "r");
15901 map_list_ptr
->map_list_map
= NULL
;
15906 while ((ch
= getc (f
)) != EOF
)
15909 struct file_name_map
*ptr
;
15913 from
= read_filename_string (ch
, f
);
15914 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
15916 to
= read_filename_string (ch
, f
);
15918 ptr
= ((struct file_name_map
*)
15919 xmalloc (sizeof (struct file_name_map
)));
15920 ptr
->map_from
= from
;
15922 /* Make the real filename absolute. */
15927 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
15928 strcpy (ptr
->map_to
, dirname
);
15929 ptr
->map_to
[dirlen
] = '/';
15930 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
15934 ptr
->map_next
= map_list_ptr
->map_list_map
;
15935 map_list_ptr
->map_list_map
= ptr
;
15937 while ((ch
= getc (f
)) != '\n')
15944 map_list_ptr
->map_list_next
= map_list
;
15945 map_list
= map_list_ptr
;
15947 return map_list_ptr
->map_list_map
;
15951 ffecom_file_ (const char *name
)
15955 /* Do partial setup of input buffer for the sake of generating
15956 early #line directives (when -g is in effect). */
15958 fp
= &instack
[++indepth
];
15959 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15962 fp
->nominal_fname
= fp
->fname
= name
;
15965 /* Initialize syntactic classifications of characters. */
15968 ffecom_initialize_char_syntax_ ()
15973 * Set up is_idchar and is_idstart tables. These should be
15974 * faster than saying (is_alpha (c) || c == '_'), etc.
15975 * Set up these things before calling any routines tthat
15978 for (i
= 'a'; i
<= 'z'; i
++) {
15979 is_idchar
[i
- 'a' + 'A'] = 1;
15981 is_idstart
[i
- 'a' + 'A'] = 1;
15984 for (i
= '0'; i
<= '9'; i
++)
15986 is_idchar
['_'] = 1;
15987 is_idstart
['_'] = 1;
15989 /* horizontal space table */
15990 is_hor_space
[' '] = 1;
15991 is_hor_space
['\t'] = 1;
15992 is_hor_space
['\v'] = 1;
15993 is_hor_space
['\f'] = 1;
15994 is_hor_space
['\r'] = 1;
15997 is_space
['\t'] = 1;
15998 is_space
['\v'] = 1;
15999 is_space
['\f'] = 1;
16000 is_space
['\n'] = 1;
16001 is_space
['\r'] = 1;
16005 ffecom_close_include_ (FILE *f
)
16010 input_file_stack_tick
++;
16012 ffewhere_line_kill (instack
[indepth
].line
);
16013 ffewhere_column_kill (instack
[indepth
].column
);
16017 ffecom_decode_include_option_ (char *spec
)
16019 struct file_name_list
*dirtmp
;
16021 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16025 dirtmp
= (struct file_name_list
*)
16026 xmalloc (sizeof (struct file_name_list
));
16027 dirtmp
->next
= 0; /* New one goes on the end */
16028 dirtmp
->fname
= spec
;
16029 dirtmp
->got_name_map
= 0;
16031 error ("Directory name must immediately follow -I");
16033 append_include_chain (dirtmp
, dirtmp
);
16038 /* Open INCLUDEd file. */
16041 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16044 size_t flen
= strlen (fbeg
);
16045 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16046 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16047 struct file_name_list
*searchptr
= 0;
16048 char *fname
; /* Dynamically allocated fname buffer */
16055 dsp
[0].fname
= NULL
;
16057 /* If -I- was specified, don't search current dir, only spec'd ones. */
16058 if (!ignore_srcdir
)
16060 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16066 if ((nam
= fp
->nominal_fname
) != NULL
)
16068 /* Found a named file. Figure out dir of the file,
16069 and put it in front of the search list. */
16070 dsp
[0].next
= search_start
;
16071 search_start
= dsp
;
16073 ep
= strrchr (nam
, '/');
16074 #ifdef DIR_SEPARATOR
16075 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
16077 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
16078 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16082 ep
= strrchr (nam
, ']');
16083 if (ep
== NULL
) ep
= strrchr (nam
, '>');
16084 if (ep
== NULL
) ep
= strrchr (nam
, ':');
16085 if (ep
!= NULL
) ep
++;
16090 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16091 strncpy (dsp
[0].fname
, nam
, n
);
16092 dsp
[0].fname
[n
] = '\0';
16093 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16094 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16097 dsp
[0].fname
= NULL
; /* Current directory */
16098 dsp
[0].got_name_map
= 0;
16104 /* Allocate this permanently, because it gets stored in the definitions
16106 fname
= xmalloc (max_include_len
+ flen
+ 4);
16107 /* + 2 above for slash and terminating null. */
16108 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16111 /* If specified file name is absolute, just open it. */
16114 #ifdef DIR_SEPARATOR
16115 || *fbeg
== DIR_SEPARATOR
16119 strncpy (fname
, (char *) fbeg
, flen
);
16121 f
= open_include_file (fname
, NULL_PTR
);
16127 /* Search directory path, trying to open the file.
16128 Copy each filename tried into FNAME. */
16130 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16132 if (searchptr
->fname
)
16134 /* The empty string in a search path is ignored.
16135 This makes it possible to turn off entirely
16136 a standard piece of the list. */
16137 if (searchptr
->fname
[0] == 0)
16139 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16140 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16141 strcat (fname
, "/");
16142 fname
[strlen (fname
) + flen
] = 0;
16147 strncat (fname
, fbeg
, flen
);
16149 /* Change this 1/2 Unix 1/2 VMS file specification into a
16150 full VMS file specification */
16151 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16153 /* Fix up the filename */
16154 hack_vms_include_specification (fname
);
16158 /* This is a normal VMS filespec, so use it unchanged. */
16159 strncpy (fname
, (char *) fbeg
, flen
);
16161 #if 0 /* Not for g77. */
16162 /* if it's '#include filename', add the missing .h */
16163 if (strchr (fname
, '.') == NULL
)
16164 strcat (fname
, ".h");
16168 f
= open_include_file (fname
, searchptr
);
16170 if (f
== NULL
&& errno
== EACCES
)
16172 print_containing_files (FFEBAD_severityWARNING
);
16173 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16174 FFEBAD_severityWARNING
);
16175 ffebad_string (fname
);
16176 ffebad_here (0, l
, c
);
16187 /* A file that was not found. */
16189 strncpy (fname
, (char *) fbeg
, flen
);
16191 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16192 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16193 ffebad_here (0, l
, c
);
16194 ffebad_string (fname
);
16198 if (dsp
[0].fname
!= NULL
)
16199 free (dsp
[0].fname
);
16204 if (indepth
>= (INPUT_STACK_MAX
- 1))
16206 print_containing_files (FFEBAD_severityFATAL
);
16207 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16208 FFEBAD_severityFATAL
);
16209 ffebad_string (fname
);
16210 ffebad_here (0, l
, c
);
16215 instack
[indepth
].line
= ffewhere_line_use (l
);
16216 instack
[indepth
].column
= ffewhere_column_use (c
);
16218 fp
= &instack
[indepth
+ 1];
16219 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16220 fp
->nominal_fname
= fp
->fname
= fname
;
16221 fp
->dir
= searchptr
;
16224 input_file_stack_tick
++;
16228 #endif /* FFECOM_GCC_INCLUDE */
16230 /**INDENT* (Do not reformat this comment even with -fca option.)
16231 Data-gathering files: Given the source file listed below, compiled with
16232 f2c I obtained the output file listed after that, and from the output
16233 file I derived the above code.
16235 -------- (begin input file to f2c)
16241 double precision D1,D2
16243 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16270 c FFEINTRIN_impACOS
16271 call fooR(ACOS(R1))
16272 c FFEINTRIN_impAIMAG
16273 call fooR(AIMAG(C1))
16274 c FFEINTRIN_impAINT
16275 call fooR(AINT(R1))
16276 c FFEINTRIN_impALOG
16277 call fooR(ALOG(R1))
16278 c FFEINTRIN_impALOG10
16279 call fooR(ALOG10(R1))
16280 c FFEINTRIN_impAMAX0
16281 call fooR(AMAX0(I1,I2))
16282 c FFEINTRIN_impAMAX1
16283 call fooR(AMAX1(R1,R2))
16284 c FFEINTRIN_impAMIN0
16285 call fooR(AMIN0(I1,I2))
16286 c FFEINTRIN_impAMIN1
16287 call fooR(AMIN1(R1,R2))
16288 c FFEINTRIN_impAMOD
16289 call fooR(AMOD(R1,R2))
16290 c FFEINTRIN_impANINT
16291 call fooR(ANINT(R1))
16292 c FFEINTRIN_impASIN
16293 call fooR(ASIN(R1))
16294 c FFEINTRIN_impATAN
16295 call fooR(ATAN(R1))
16296 c FFEINTRIN_impATAN2
16297 call fooR(ATAN2(R1,R2))
16298 c FFEINTRIN_impCABS
16299 call fooR(CABS(C1))
16300 c FFEINTRIN_impCCOS
16301 call fooC(CCOS(C1))
16302 c FFEINTRIN_impCEXP
16303 call fooC(CEXP(C1))
16304 c FFEINTRIN_impCHAR
16305 call fooA(CHAR(I1))
16306 c FFEINTRIN_impCLOG
16307 call fooC(CLOG(C1))
16308 c FFEINTRIN_impCONJG
16309 call fooC(CONJG(C1))
16312 c FFEINTRIN_impCOSH
16313 call fooR(COSH(R1))
16314 c FFEINTRIN_impCSIN
16315 call fooC(CSIN(C1))
16316 c FFEINTRIN_impCSQRT
16317 call fooC(CSQRT(C1))
16318 c FFEINTRIN_impDABS
16319 call fooD(DABS(D1))
16320 c FFEINTRIN_impDACOS
16321 call fooD(DACOS(D1))
16322 c FFEINTRIN_impDASIN
16323 call fooD(DASIN(D1))
16324 c FFEINTRIN_impDATAN
16325 call fooD(DATAN(D1))
16326 c FFEINTRIN_impDATAN2
16327 call fooD(DATAN2(D1,D2))
16328 c FFEINTRIN_impDCOS
16329 call fooD(DCOS(D1))
16330 c FFEINTRIN_impDCOSH
16331 call fooD(DCOSH(D1))
16332 c FFEINTRIN_impDDIM
16333 call fooD(DDIM(D1,D2))
16334 c FFEINTRIN_impDEXP
16335 call fooD(DEXP(D1))
16337 call fooR(DIM(R1,R2))
16338 c FFEINTRIN_impDINT
16339 call fooD(DINT(D1))
16340 c FFEINTRIN_impDLOG
16341 call fooD(DLOG(D1))
16342 c FFEINTRIN_impDLOG10
16343 call fooD(DLOG10(D1))
16344 c FFEINTRIN_impDMAX1
16345 call fooD(DMAX1(D1,D2))
16346 c FFEINTRIN_impDMIN1
16347 call fooD(DMIN1(D1,D2))
16348 c FFEINTRIN_impDMOD
16349 call fooD(DMOD(D1,D2))
16350 c FFEINTRIN_impDNINT
16351 call fooD(DNINT(D1))
16352 c FFEINTRIN_impDPROD
16353 call fooD(DPROD(R1,R2))
16354 c FFEINTRIN_impDSIGN
16355 call fooD(DSIGN(D1,D2))
16356 c FFEINTRIN_impDSIN
16357 call fooD(DSIN(D1))
16358 c FFEINTRIN_impDSINH
16359 call fooD(DSINH(D1))
16360 c FFEINTRIN_impDSQRT
16361 call fooD(DSQRT(D1))
16362 c FFEINTRIN_impDTAN
16363 call fooD(DTAN(D1))
16364 c FFEINTRIN_impDTANH
16365 call fooD(DTANH(D1))
16368 c FFEINTRIN_impIABS
16369 call fooI(IABS(I1))
16370 c FFEINTRIN_impICHAR
16371 call fooI(ICHAR(A1))
16372 c FFEINTRIN_impIDIM
16373 call fooI(IDIM(I1,I2))
16374 c FFEINTRIN_impIDNINT
16375 call fooI(IDNINT(D1))
16376 c FFEINTRIN_impINDEX
16377 call fooI(INDEX(A1,A2))
16378 c FFEINTRIN_impISIGN
16379 call fooI(ISIGN(I1,I2))
16383 call fooL(LGE(A1,A2))
16385 call fooL(LGT(A1,A2))
16387 call fooL(LLE(A1,A2))
16389 call fooL(LLT(A1,A2))
16390 c FFEINTRIN_impMAX0
16391 call fooI(MAX0(I1,I2))
16392 c FFEINTRIN_impMAX1
16393 call fooI(MAX1(R1,R2))
16394 c FFEINTRIN_impMIN0
16395 call fooI(MIN0(I1,I2))
16396 c FFEINTRIN_impMIN1
16397 call fooI(MIN1(R1,R2))
16399 call fooI(MOD(I1,I2))
16400 c FFEINTRIN_impNINT
16401 call fooI(NINT(R1))
16402 c FFEINTRIN_impSIGN
16403 call fooR(SIGN(R1,R2))
16406 c FFEINTRIN_impSINH
16407 call fooR(SINH(R1))
16408 c FFEINTRIN_impSQRT
16409 call fooR(SQRT(R1))
16412 c FFEINTRIN_impTANH
16413 call fooR(TANH(R1))
16414 c FFEINTRIN_imp_CMPLX_C
16415 call fooC(cmplx(C1,C2))
16416 c FFEINTRIN_imp_CMPLX_D
16417 call fooZ(cmplx(D1,D2))
16418 c FFEINTRIN_imp_CMPLX_I
16419 call fooC(cmplx(I1,I2))
16420 c FFEINTRIN_imp_CMPLX_R
16421 call fooC(cmplx(R1,R2))
16422 c FFEINTRIN_imp_DBLE_C
16423 call fooD(dble(C1))
16424 c FFEINTRIN_imp_DBLE_D
16425 call fooD(dble(D1))
16426 c FFEINTRIN_imp_DBLE_I
16427 call fooD(dble(I1))
16428 c FFEINTRIN_imp_DBLE_R
16429 call fooD(dble(R1))
16430 c FFEINTRIN_imp_INT_C
16432 c FFEINTRIN_imp_INT_D
16434 c FFEINTRIN_imp_INT_I
16436 c FFEINTRIN_imp_INT_R
16438 c FFEINTRIN_imp_REAL_C
16439 call fooR(real(C1))
16440 c FFEINTRIN_imp_REAL_D
16441 call fooR(real(D1))
16442 c FFEINTRIN_imp_REAL_I
16443 call fooR(real(I1))
16444 c FFEINTRIN_imp_REAL_R
16445 call fooR(real(R1))
16447 c FFEINTRIN_imp_INT_D:
16449 c FFEINTRIN_specIDINT
16450 call fooI(IDINT(D1))
16452 c FFEINTRIN_imp_INT_R:
16454 c FFEINTRIN_specIFIX
16455 call fooI(IFIX(R1))
16456 c FFEINTRIN_specINT
16459 c FFEINTRIN_imp_REAL_D:
16461 c FFEINTRIN_specSNGL
16462 call fooR(SNGL(D1))
16464 c FFEINTRIN_imp_REAL_I:
16466 c FFEINTRIN_specFLOAT
16467 call fooR(FLOAT(I1))
16468 c FFEINTRIN_specREAL
16469 call fooR(REAL(I1))
16472 -------- (end input file to f2c)
16474 -------- (begin output from providing above input file as input to:
16475 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16476 -------- -e "s:^#.*$::g"')
16478 // -- translated by f2c (version 19950223).
16479 You must link the resulting object file with the libraries:
16480 -lf2c -lm (in that order)
16484 // f2c.h -- Standard Fortran to C header file //
16486 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16488 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16493 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16494 // we assume short, float are OK //
16495 typedef long int // long int // integer;
16496 typedef char *address;
16497 typedef short int shortint;
16498 typedef float real;
16499 typedef double doublereal;
16500 typedef struct { real r, i; } complex;
16501 typedef struct { doublereal r, i; } doublecomplex;
16502 typedef long int // long int // logical;
16503 typedef short int shortlogical;
16504 typedef char logical1;
16505 typedef char integer1;
16506 // typedef long long longint; // // system-dependent //
16511 // Extern is for use with -E //
16525 typedef long int // int or long int // flag;
16526 typedef long int // int or long int // ftnlen;
16527 typedef long int // int or long int // ftnint;
16530 //external read, write//
16539 //internal read, write//
16569 //rewind, backspace, endfile//
16581 ftnint *inex; //parameters in standard's order//
16607 union Multitype { // for multiple entry points //
16618 typedef union Multitype Multitype;
16620 typedef long Long; // No longer used; formerly in Namelist //
16622 struct Vardesc { // for Namelist //
16628 typedef struct Vardesc Vardesc;
16635 typedef struct Namelist Namelist;
16644 // procedure parameter types for -A and -C++ //
16649 typedef int // Unknown procedure type // (*U_fp)();
16650 typedef shortint (*J_fp)();
16651 typedef integer (*I_fp)();
16652 typedef real (*R_fp)();
16653 typedef doublereal (*D_fp)(), (*E_fp)();
16654 typedef // Complex // void (*C_fp)();
16655 typedef // Double Complex // void (*Z_fp)();
16656 typedef logical (*L_fp)();
16657 typedef shortlogical (*K_fp)();
16658 typedef // Character // void (*H_fp)();
16659 typedef // Subroutine // int (*S_fp)();
16661 // E_fp is for real functions when -R is not specified //
16662 typedef void C_f; // complex function //
16663 typedef void H_f; // character function //
16664 typedef void Z_f; // double complex function //
16665 typedef doublereal E_f; // real function with -R not specified //
16667 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16670 // (No such symbols should be defined in a strict ANSI C compiler.
16671 We can avoid trouble with f2c-translated code by using
16672 gcc -ansi [-traditional].) //
16696 // Main program // MAIN__()
16698 // System generated locals //
16701 doublereal d__1, d__2;
16703 doublecomplex z__1, z__2, z__3;
16707 // Builtin functions //
16710 double pow_ri(), pow_di();
16714 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16715 asin(), atan(), atan2(), c_abs();
16716 void c_cos(), c_exp(), c_log(), r_cnjg();
16717 double cos(), cosh();
16718 void c_sin(), c_sqrt();
16719 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16720 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16721 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16722 logical l_ge(), l_gt(), l_le(), l_lt();
16726 // Local variables //
16727 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16728 fool_(), fooz_(), getem_();
16729 static char a1[10], a2[10];
16730 static complex c1, c2;
16731 static doublereal d1, d2;
16732 static integer i1, i2;
16733 static real r1, r2;
16736 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16744 d__1 = (doublereal) i1;
16745 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16755 c_div(&q__1, &c1, &c2);
16757 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16759 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16762 i__1 = pow_ii(&i1, &i2);
16764 r__1 = pow_ri(&r1, &i1);
16766 d__1 = pow_di(&d1, &i1);
16768 pow_ci(&q__1, &c1, &i1);
16770 d__1 = (doublereal) r1;
16771 d__2 = (doublereal) r2;
16772 r__1 = pow_dd(&d__1, &d__2);
16774 d__2 = (doublereal) r1;
16775 d__1 = pow_dd(&d__2, &d1);
16777 d__1 = pow_dd(&d1, &d2);
16779 d__2 = (doublereal) r1;
16780 d__1 = pow_dd(&d1, &d__2);
16782 z__2.r = c1.r, z__2.i = c1.i;
16783 z__3.r = c2.r, z__3.i = c2.i;
16784 pow_zz(&z__1, &z__2, &z__3);
16785 q__1.r = z__1.r, q__1.i = z__1.i;
16787 z__2.r = c1.r, z__2.i = c1.i;
16788 z__3.r = r1, z__3.i = 0.;
16789 pow_zz(&z__1, &z__2, &z__3);
16790 q__1.r = z__1.r, q__1.i = z__1.i;
16792 z__2.r = c1.r, z__2.i = c1.i;
16793 z__3.r = d1, z__3.i = 0.;
16794 pow_zz(&z__1, &z__2, &z__3);
16796 // FFEINTRIN_impABS //
16797 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16799 // FFEINTRIN_impACOS //
16802 // FFEINTRIN_impAIMAG //
16803 r__1 = r_imag(&c1);
16805 // FFEINTRIN_impAINT //
16808 // FFEINTRIN_impALOG //
16811 // FFEINTRIN_impALOG10 //
16812 r__1 = r_lg10(&r1);
16814 // FFEINTRIN_impAMAX0 //
16815 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16817 // FFEINTRIN_impAMAX1 //
16818 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16820 // FFEINTRIN_impAMIN0 //
16821 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16823 // FFEINTRIN_impAMIN1 //
16824 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16826 // FFEINTRIN_impAMOD //
16827 r__1 = r_mod(&r1, &r2);
16829 // FFEINTRIN_impANINT //
16830 r__1 = r_nint(&r1);
16832 // FFEINTRIN_impASIN //
16835 // FFEINTRIN_impATAN //
16838 // FFEINTRIN_impATAN2 //
16839 r__1 = atan2(r1, r2);
16841 // FFEINTRIN_impCABS //
16844 // FFEINTRIN_impCCOS //
16847 // FFEINTRIN_impCEXP //
16850 // FFEINTRIN_impCHAR //
16851 *(unsigned char *)&ch__1[0] = i1;
16853 // FFEINTRIN_impCLOG //
16856 // FFEINTRIN_impCONJG //
16857 r_cnjg(&q__1, &c1);
16859 // FFEINTRIN_impCOS //
16862 // FFEINTRIN_impCOSH //
16865 // FFEINTRIN_impCSIN //
16868 // FFEINTRIN_impCSQRT //
16869 c_sqrt(&q__1, &c1);
16871 // FFEINTRIN_impDABS //
16872 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16874 // FFEINTRIN_impDACOS //
16877 // FFEINTRIN_impDASIN //
16880 // FFEINTRIN_impDATAN //
16883 // FFEINTRIN_impDATAN2 //
16884 d__1 = atan2(d1, d2);
16886 // FFEINTRIN_impDCOS //
16889 // FFEINTRIN_impDCOSH //
16892 // FFEINTRIN_impDDIM //
16893 d__1 = d_dim(&d1, &d2);
16895 // FFEINTRIN_impDEXP //
16898 // FFEINTRIN_impDIM //
16899 r__1 = r_dim(&r1, &r2);
16901 // FFEINTRIN_impDINT //
16904 // FFEINTRIN_impDLOG //
16907 // FFEINTRIN_impDLOG10 //
16908 d__1 = d_lg10(&d1);
16910 // FFEINTRIN_impDMAX1 //
16911 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16913 // FFEINTRIN_impDMIN1 //
16914 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16916 // FFEINTRIN_impDMOD //
16917 d__1 = d_mod(&d1, &d2);
16919 // FFEINTRIN_impDNINT //
16920 d__1 = d_nint(&d1);
16922 // FFEINTRIN_impDPROD //
16923 d__1 = (doublereal) r1 * r2;
16925 // FFEINTRIN_impDSIGN //
16926 d__1 = d_sign(&d1, &d2);
16928 // FFEINTRIN_impDSIN //
16931 // FFEINTRIN_impDSINH //
16934 // FFEINTRIN_impDSQRT //
16937 // FFEINTRIN_impDTAN //
16940 // FFEINTRIN_impDTANH //
16943 // FFEINTRIN_impEXP //
16946 // FFEINTRIN_impIABS //
16947 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16949 // FFEINTRIN_impICHAR //
16950 i__1 = *(unsigned char *)a1;
16952 // FFEINTRIN_impIDIM //
16953 i__1 = i_dim(&i1, &i2);
16955 // FFEINTRIN_impIDNINT //
16956 i__1 = i_dnnt(&d1);
16958 // FFEINTRIN_impINDEX //
16959 i__1 = i_indx(a1, a2, 10L, 10L);
16961 // FFEINTRIN_impISIGN //
16962 i__1 = i_sign(&i1, &i2);
16964 // FFEINTRIN_impLEN //
16965 i__1 = i_len(a1, 10L);
16967 // FFEINTRIN_impLGE //
16968 L__1 = l_ge(a1, a2, 10L, 10L);
16970 // FFEINTRIN_impLGT //
16971 L__1 = l_gt(a1, a2, 10L, 10L);
16973 // FFEINTRIN_impLLE //
16974 L__1 = l_le(a1, a2, 10L, 10L);
16976 // FFEINTRIN_impLLT //
16977 L__1 = l_lt(a1, a2, 10L, 10L);
16979 // FFEINTRIN_impMAX0 //
16980 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16982 // FFEINTRIN_impMAX1 //
16983 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16985 // FFEINTRIN_impMIN0 //
16986 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16988 // FFEINTRIN_impMIN1 //
16989 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16991 // FFEINTRIN_impMOD //
16994 // FFEINTRIN_impNINT //
16995 i__1 = i_nint(&r1);
16997 // FFEINTRIN_impSIGN //
16998 r__1 = r_sign(&r1, &r2);
17000 // FFEINTRIN_impSIN //
17003 // FFEINTRIN_impSINH //
17006 // FFEINTRIN_impSQRT //
17009 // FFEINTRIN_impTAN //
17012 // FFEINTRIN_impTANH //
17015 // FFEINTRIN_imp_CMPLX_C //
17018 q__1.r = r__1, q__1.i = r__2;
17020 // FFEINTRIN_imp_CMPLX_D //
17021 z__1.r = d1, z__1.i = d2;
17023 // FFEINTRIN_imp_CMPLX_I //
17026 q__1.r = r__1, q__1.i = r__2;
17028 // FFEINTRIN_imp_CMPLX_R //
17029 q__1.r = r1, q__1.i = r2;
17031 // FFEINTRIN_imp_DBLE_C //
17032 d__1 = (doublereal) c1.r;
17034 // FFEINTRIN_imp_DBLE_D //
17037 // FFEINTRIN_imp_DBLE_I //
17038 d__1 = (doublereal) i1;
17040 // FFEINTRIN_imp_DBLE_R //
17041 d__1 = (doublereal) r1;
17043 // FFEINTRIN_imp_INT_C //
17044 i__1 = (integer) c1.r;
17046 // FFEINTRIN_imp_INT_D //
17047 i__1 = (integer) d1;
17049 // FFEINTRIN_imp_INT_I //
17052 // FFEINTRIN_imp_INT_R //
17053 i__1 = (integer) r1;
17055 // FFEINTRIN_imp_REAL_C //
17058 // FFEINTRIN_imp_REAL_D //
17061 // FFEINTRIN_imp_REAL_I //
17064 // FFEINTRIN_imp_REAL_R //
17068 // FFEINTRIN_imp_INT_D: //
17070 // FFEINTRIN_specIDINT //
17071 i__1 = (integer) d1;
17074 // FFEINTRIN_imp_INT_R: //
17076 // FFEINTRIN_specIFIX //
17077 i__1 = (integer) r1;
17079 // FFEINTRIN_specINT //
17080 i__1 = (integer) r1;
17083 // FFEINTRIN_imp_REAL_D: //
17085 // FFEINTRIN_specSNGL //
17089 // FFEINTRIN_imp_REAL_I: //
17091 // FFEINTRIN_specFLOAT //
17094 // FFEINTRIN_specREAL //
17100 -------- (end output file from f2c)