1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
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):
58 yes = suspend_momentary ();
59 if (is_nested) push_f_function_context ();
60 start_function (get_identifier ("function_name"), function_type,
61 is_nested, is_public);
62 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
63 store_parm_decls (is_main_program);
64 ffecom_start_compstmt ();
65 // for stmts and decls inside function, do appropriate things;
66 ffecom_end_compstmt ();
67 finish_function (is_nested);
68 if (is_nested) pop_f_function_context ();
69 if (is_nested) resume_momentary (yes);
75 yes = suspend_momentary ();
76 // fill in external, public, static, &c for decl, and
77 // set DECL_INITIAL to error_mark_node if going to initialize
78 // set is_top_level TRUE only if not at top level and decl
79 // must go in top level (i.e. not within current function decl context)
80 d = start_decl (decl, is_top_level);
81 init = ...; // if have initializer
82 finish_decl (d, init, is_top_level);
83 resume_momentary (yes);
90 #if FFECOM_targetCURRENT == FFECOM_targetGCC
95 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
98 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
100 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
102 /* BEGIN stuff from gcc/cccp.c. */
104 /* The following symbols should be autoconfigured:
111 In the mean time, we'll get by with approximations based
112 on existing GCC configuration symbols. */
115 # ifndef HAVE_STDLIB_H
116 # define HAVE_STDLIB_H 1
118 # ifndef HAVE_UNISTD_H
119 # define HAVE_UNISTD_H 1
121 # ifndef STDC_HEADERS
122 # define STDC_HEADERS 1
124 #endif /* defined (POSIX) */
126 #if defined (POSIX) || (defined (USG) && !defined (VMS))
127 # ifndef HAVE_FCNTL_H
128 # define HAVE_FCNTL_H 1
135 # if TIME_WITH_SYS_TIME
136 # include <sys/time.h>
140 # include <sys/time.h>
145 # include <sys/resource.h>
152 /* This defines "errno" properly for VMS, and gives us EACCES. */
165 /* VMS-specific definitions */
168 #define O_RDONLY 0 /* Open arg for Read/Only */
169 #define O_WRONLY 1 /* Open arg for Write/Only */
170 #define read(fd,buf,size) VMS_read (fd,buf,size)
171 #define write(fd,buf,size) VMS_write (fd,buf,size)
172 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
173 #define fopen(fname,mode) VMS_fopen (fname,mode)
174 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
175 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
176 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
177 static int VMS_fstat (), VMS_stat ();
178 static char * VMS_strncat ();
179 static int VMS_read ();
180 static int VMS_write ();
181 static int VMS_open ();
182 static FILE * VMS_fopen ();
183 static FILE * VMS_freopen ();
184 static void hack_vms_include_specification ();
185 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
186 #define ino_t vms_ino_t
187 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
189 #define BSTRING /* VMS/GCC supplies the bstring routines */
190 #endif /* __GNUC__ */
197 /* END stuff from gcc/cccp.c. */
199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
216 /* Externals defined here. */
218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
220 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
223 const char * const language_string
= "GNU F77";
225 /* Stream for reading from the input file. */
228 /* These definitions parallel those in c-decl.c so that code from that
229 module can be used pretty much as is. Much of these defs aren't
230 otherwise used, i.e. by g77 code per se, except some of them are used
231 to build some of them that are. The ones that are global (i.e. not
232 "static") are those that ste.c and such might use (directly
233 or by using com macros that reference them in their definitions). */
235 tree string_type_node
;
237 /* The rest of these are inventions for g77, though there might be
238 similar things in the C front end. As they are found, these
239 inventions should be renamed to be canonical. Note that only
240 the ones currently required to be global are so. */
242 static tree ffecom_tree_fun_type_void
;
244 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
245 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
246 tree ffecom_integer_one_node
; /* " */
247 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
249 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
250 just use build_function_type and build_pointer_type on the
251 appropriate _tree_type array element. */
253 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
254 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
255 static tree ffecom_tree_subr_type
;
256 static tree ffecom_tree_ptr_to_subr_type
;
257 static tree ffecom_tree_blockdata_type
;
259 static tree ffecom_tree_xargc_
;
261 ffecomSymbol ffecom_symbol_null_
270 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
271 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
273 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
274 tree ffecom_f2c_integer_type_node
;
275 tree ffecom_f2c_ptr_to_integer_type_node
;
276 tree ffecom_f2c_address_type_node
;
277 tree ffecom_f2c_real_type_node
;
278 tree ffecom_f2c_ptr_to_real_type_node
;
279 tree ffecom_f2c_doublereal_type_node
;
280 tree ffecom_f2c_complex_type_node
;
281 tree ffecom_f2c_doublecomplex_type_node
;
282 tree ffecom_f2c_longint_type_node
;
283 tree ffecom_f2c_logical_type_node
;
284 tree ffecom_f2c_flag_type_node
;
285 tree ffecom_f2c_ftnlen_type_node
;
286 tree ffecom_f2c_ftnlen_zero_node
;
287 tree ffecom_f2c_ftnlen_one_node
;
288 tree ffecom_f2c_ftnlen_two_node
;
289 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
290 tree ffecom_f2c_ftnint_type_node
;
291 tree ffecom_f2c_ptr_to_ftnint_type_node
;
292 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
294 /* Simple definitions and enumerations. */
296 #ifndef FFECOM_sizeMAXSTACKITEM
297 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
298 larger than this # bytes
299 off stack if possible. */
302 /* For systems that have large enough stacks, they should define
303 this to 0, and here, for ease of use later on, we just undefine
306 #if FFECOM_sizeMAXSTACKITEM == 0
307 #undef FFECOM_sizeMAXSTACKITEM
313 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
314 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
315 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
316 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
317 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
318 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
319 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
320 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
321 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
322 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
323 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
324 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
325 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
326 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
330 /* Internal typedefs. */
332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
333 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
334 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
336 /* Private include files. */
339 /* Internal structure definitions. */
341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
342 struct _ffecom_concat_list_
347 ffetargetCharacterSize minlen
;
348 ffetargetCharacterSize maxlen
;
350 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
352 /* Static functions (internal). */
354 #if FFECOM_targetCURRENT == FFECOM_targetGCC
355 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
356 static tree
ffecom_widest_expr_type_ (ffebld list
);
357 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
358 tree dest_size
, tree source_tree
,
359 ffebld source
, bool scalar_arg
);
360 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
361 tree args
, tree callee_commons
,
363 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
364 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
365 bool is_f2c_complex
, tree type
,
366 tree args
, tree dest_tree
,
367 ffebld dest
, bool *dest_used
,
368 tree callee_commons
, bool scalar_args
, tree hook
);
369 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
370 bool is_f2c_complex
, tree type
,
371 ffebld left
, ffebld right
,
372 tree dest_tree
, ffebld dest
,
373 bool *dest_used
, tree callee_commons
,
374 bool scalar_args
, tree hook
);
375 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
376 ffebld expr
, bool with_null
);
377 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
378 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
379 static ffecomConcatList_
380 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
382 ffetargetCharacterSize max
);
383 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
384 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
385 ffetargetCharacterSize max
);
386 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
387 ffesymbol member
, tree member_type
,
388 ffetargetOffset offset
);
389 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
390 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
391 bool *dest_used
, bool assignp
, bool widenp
);
392 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
393 ffebld dest
, bool *dest_used
);
394 static tree
ffecom_expr_power_integer_ (ffebld expr
);
395 static void ffecom_expr_transform_ (ffebld expr
);
396 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
397 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
399 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
400 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
401 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
402 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
403 static tree
ffecom_get_identifier_ (const char *text
);
404 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
407 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
408 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
409 static tree
ffecom_init_zero_ (tree decl
);
410 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
412 static tree
ffecom_intrinsic_len_ (ffebld expr
);
413 static void ffecom_let_char_ (tree dest_tree
,
415 ffetargetCharacterSize dest_size
,
417 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
418 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
419 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
420 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
422 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
424 static void ffecom_start_progunit_ (void);
425 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
426 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
427 static void ffecom_transform_common_ (ffesymbol s
);
428 static void ffecom_transform_equiv_ (ffestorag st
);
429 static tree
ffecom_transform_namelist_ (ffesymbol s
);
430 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
432 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
433 tree
*size
, tree tree
);
434 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
435 tree dest_tree
, ffebld dest
,
436 bool *dest_used
, tree hook
);
437 static tree
ffecom_type_localvar_ (ffesymbol s
,
440 static tree
ffecom_type_namelist_ (void);
441 static tree
ffecom_type_vardesc_ (void);
442 static tree
ffecom_vardesc_ (ffebld expr
);
443 static tree
ffecom_vardesc_array_ (ffesymbol s
);
444 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
445 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
446 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
447 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
449 /* These are static functions that parallel those found in the C front
450 end and thus have the same names. */
452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
453 static tree
bison_rule_compstmt_ (void);
454 static void bison_rule_pushlevel_ (void);
455 static void delete_block (tree block
);
456 static int duplicate_decls (tree newdecl
, tree olddecl
);
457 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
458 static void finish_function (int nested
);
459 static const char *lang_printable_name (tree decl
, int v
);
460 static tree
lookup_name_current_level (tree name
);
461 static struct binding_level
*make_binding_level (void);
462 static void pop_f_function_context (void);
463 static void push_f_function_context (void);
464 static void push_parm_decl (tree parm
);
465 static tree
pushdecl_top_level (tree decl
);
466 static int kept_level_p (void);
467 static tree
storedecls (tree decls
);
468 static void store_parm_decls (int is_main_program
);
469 static tree
start_decl (tree decl
, bool is_top_level
);
470 static void start_function (tree name
, tree type
, int nested
, int public);
471 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
472 #if FFECOM_GCC_INCLUDE
473 static void ffecom_file_ (const char *name
);
474 static void ffecom_initialize_char_syntax_ (void);
475 static void ffecom_close_include_ (FILE *f
);
476 static int ffecom_decode_include_option_ (char *spec
);
477 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
479 #endif /* FFECOM_GCC_INCLUDE */
481 /* Static objects accessed by functions in this module. */
483 static ffesymbol ffecom_primary_entry_
= NULL
;
484 static ffesymbol ffecom_nested_entry_
= NULL
;
485 static ffeinfoKind ffecom_primary_entry_kind_
;
486 static bool ffecom_primary_entry_is_proc_
;
487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
488 static tree ffecom_outer_function_decl_
;
489 static tree ffecom_previous_function_decl_
;
490 static tree ffecom_which_entrypoint_decl_
;
491 static tree ffecom_float_zero_
= NULL_TREE
;
492 static tree ffecom_float_half_
= NULL_TREE
;
493 static tree ffecom_double_zero_
= NULL_TREE
;
494 static tree ffecom_double_half_
= NULL_TREE
;
495 static tree ffecom_func_result_
;/* For functions. */
496 static tree ffecom_func_length_
;/* For CHARACTER fns. */
497 static ffebld ffecom_list_blockdata_
;
498 static ffebld ffecom_list_common_
;
499 static ffebld ffecom_master_arglist_
;
500 static ffeinfoBasictype ffecom_master_bt_
;
501 static ffeinfoKindtype ffecom_master_kt_
;
502 static ffetargetCharacterSize ffecom_master_size_
;
503 static int ffecom_num_fns_
= 0;
504 static int ffecom_num_entrypoints_
= 0;
505 static bool ffecom_is_altreturning_
= FALSE
;
506 static tree ffecom_multi_type_node_
;
507 static tree ffecom_multi_retval_
;
509 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
510 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
511 static bool ffecom_doing_entry_
= FALSE
;
512 static bool ffecom_transform_only_dummies_
= FALSE
;
513 static int ffecom_typesize_pointer_
;
514 static int ffecom_typesize_integer1_
;
516 /* Holds pointer-to-function expressions. */
518 static tree ffecom_gfrt_
[FFECOM_gfrt
]
521 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
522 #include "com-rt.def"
526 /* Holds the external names of the functions. */
528 static const char *ffecom_gfrt_name_
[FFECOM_gfrt
]
531 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
532 #include "com-rt.def"
536 /* Whether the function returns. */
538 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
541 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
542 #include "com-rt.def"
546 /* Whether the function returns type complex. */
548 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
551 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
552 #include "com-rt.def"
556 /* Type code for the function return value. */
558 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
561 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
562 #include "com-rt.def"
566 /* String of codes for the function's arguments. */
568 static const char *ffecom_gfrt_argstring_
[FFECOM_gfrt
]
571 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
572 #include "com-rt.def"
575 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
577 /* Internal macros. */
579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
581 /* We let tm.h override the types used here, to handle trivial differences
582 such as the choice of unsigned int or long unsigned int for size_t.
583 When machines start needing nontrivial differences in the size type,
584 it would be best to do something here to figure out automatically
585 from other information what type to use. */
588 #define SIZE_TYPE "long unsigned int"
591 #define ffecom_concat_list_count_(catlist) ((catlist).count)
592 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
593 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
594 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
596 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
597 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
599 /* For each binding contour we allocate a binding_level structure
600 * which records the names defined in that contour.
603 * 1) one for each function definition,
604 * where internal declarations of the parameters appear.
606 * The current meaning of a name can be found by searching the levels from
607 * the current one out to the global one.
610 /* Note that the information in the `names' component of the global contour
611 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
615 /* A chain of _DECL nodes for all variables, constants, functions,
616 and typedef types. These are in the reverse of the order supplied.
620 /* For each level (except not the global one),
621 a chain of BLOCK nodes for all the levels
622 that were entered and exited one level down. */
625 /* The BLOCK node for this level, if one has been preallocated.
626 If 0, the BLOCK is allocated (if needed) when the level is popped. */
629 /* The binding level which this one is contained in (inherits from). */
630 struct binding_level
*level_chain
;
632 /* 0: no ffecom_prepare_* functions called at this level yet;
633 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
634 2: ffecom_prepare_end called. */
638 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
640 /* The binding level currently in effect. */
642 static struct binding_level
*current_binding_level
;
644 /* A chain of binding_level structures awaiting reuse. */
646 static struct binding_level
*free_binding_level
;
648 /* The outermost binding level, for names of file scope.
649 This is created when the compiler is started and exists
650 through the entire run. */
652 static struct binding_level
*global_binding_level
;
654 /* Binding level structures are initialized by copying this one. */
656 static struct binding_level clear_binding_level
658 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
660 /* Language-dependent contents of an identifier. */
662 struct lang_identifier
664 struct tree_identifier ignore
;
665 tree global_value
, local_value
, label_value
;
669 /* Macros for access to language-specific slots in an identifier. */
670 /* Each of these slots contains a DECL node or null. */
672 /* This represents the value which the identifier has in the
673 file-scope namespace. */
674 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
675 (((struct lang_identifier *)(NODE))->global_value)
676 /* This represents the value which the identifier has in the current
678 #define IDENTIFIER_LOCAL_VALUE(NODE) \
679 (((struct lang_identifier *)(NODE))->local_value)
680 /* This represents the value which the identifier has as a label in
681 the current label scope. */
682 #define IDENTIFIER_LABEL_VALUE(NODE) \
683 (((struct lang_identifier *)(NODE))->label_value)
684 /* This is nonzero if the identifier was "made up" by g77 code. */
685 #define IDENTIFIER_INVENTED(NODE) \
686 (((struct lang_identifier *)(NODE))->invented)
688 /* In identifiers, C uses the following fields in a special way:
689 TREE_PUBLIC to record that there was a previous local extern decl.
690 TREE_USED to record that such a decl was used.
691 TREE_ADDRESSABLE to record that the address of such a decl was used. */
693 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
694 that have names. Here so we can clear out their names' definitions
695 at the end of the function. */
697 static tree named_labels
;
699 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
701 static tree shadowed_labels
;
703 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
705 /* Return the subscript expression, modified to do range-checking.
707 `array' is the array to be checked against.
708 `element' is the subscript expression to check.
709 `dim' is the dimension number (starting at 0).
710 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
714 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
715 const char *array_name
)
717 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
718 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
723 if (element
== error_mark_node
)
726 if (TREE_TYPE (low
) != TREE_TYPE (element
))
728 if (TYPE_PRECISION (TREE_TYPE (low
))
729 > TYPE_PRECISION (TREE_TYPE (element
)))
730 element
= convert (TREE_TYPE (low
), element
);
733 low
= convert (TREE_TYPE (element
), low
);
735 high
= convert (TREE_TYPE (element
), high
);
739 element
= ffecom_save_tree (element
);
740 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
745 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
747 ffecom_2 (LE_EXPR
, integer_type_node
,
764 var
= xmalloc (strlen (array_name
) + 20);
765 sprintf (var
, "%s[%s-substring]",
767 dim
? "end" : "start");
768 len
= strlen (var
) + 1;
769 arg1
= build_string (len
, var
);
774 len
= strlen (array_name
) + 1;
775 arg1
= build_string (len
, array_name
);
779 var
= xmalloc (strlen (array_name
) + 40);
780 sprintf (var
, "%s[subscript-%d-of-%d]",
782 dim
+ 1, total_dims
);
783 len
= strlen (var
) + 1;
784 arg1
= build_string (len
, var
);
790 = build_type_variant (build_array_type (char_type_node
,
794 build_int_2 (len
, 0))),
796 TREE_CONSTANT (arg1
) = 1;
797 TREE_STATIC (arg1
) = 1;
798 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
801 /* s_rnge adds one to the element to print it, so bias against
802 that -- want to print a faithful *subscript* value. */
803 arg2
= convert (ffecom_f2c_ftnint_type_node
,
804 ffecom_2 (MINUS_EXPR
,
807 convert (TREE_TYPE (element
),
810 proc
= xmalloc ((len
= strlen (input_filename
)
811 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl
))
814 sprintf (&proc
[0], "%s/%s",
816 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)));
817 arg3
= build_string (len
, proc
);
822 = build_type_variant (build_array_type (char_type_node
,
826 build_int_2 (len
, 0))),
828 TREE_CONSTANT (arg3
) = 1;
829 TREE_STATIC (arg3
) = 1;
830 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
833 arg4
= convert (ffecom_f2c_ftnint_type_node
,
834 build_int_2 (lineno
, 0));
836 arg1
= build_tree_list (NULL_TREE
, arg1
);
837 arg2
= build_tree_list (NULL_TREE
, arg2
);
838 arg3
= build_tree_list (NULL_TREE
, arg3
);
839 arg4
= build_tree_list (NULL_TREE
, arg4
);
840 TREE_CHAIN (arg3
) = arg4
;
841 TREE_CHAIN (arg2
) = arg3
;
842 TREE_CHAIN (arg1
) = arg2
;
846 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
848 TREE_SIDE_EFFECTS (die
) = 1;
850 element
= ffecom_3 (COND_EXPR
,
859 /* Return the computed element of an array reference.
861 `item' is NULL_TREE, or the transformed pointer to the array.
862 `expr' is the original opARRAYREF expression, which is transformed
863 if `item' is NULL_TREE.
864 `want_ptr' is non-zero if a pointer to the element, instead of
865 the element itself, is to be returned. */
868 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
870 ffebld dims
[FFECOM_dimensionsMAX
];
873 int flatten
= ffe_is_flatten_arrays ();
879 const char *array_name
;
883 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
884 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
886 array_name
= "[expr?]";
888 /* Build up ARRAY_REFs in reverse order (since we're column major
889 here in Fortran land). */
891 for (i
= 0, list
= ffebld_right (expr
);
893 ++i
, list
= ffebld_trail (list
))
895 dims
[i
] = ffebld_head (list
);
896 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
897 ffebld_kindtype (dims
[i
]));
899 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
900 && ffetype_size (type
) > ffecom_typesize_integer1_
)
901 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
902 pointers and 32-bit integers. Do the full 64-bit pointer
903 arithmetic, for codes using arrays for nonstandard heap-like
910 need_ptr
= want_ptr
|| flatten
;
915 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
917 item
= ffecom_expr (ffebld_left (expr
));
919 if (item
== error_mark_node
)
922 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
923 && ! mark_addressable (item
))
924 return error_mark_node
;
927 if (item
== error_mark_node
)
934 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
936 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
938 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
939 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
940 if (flag_bounds_check
)
941 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
943 if (element
== error_mark_node
)
946 /* Widen integral arithmetic as desired while preserving
948 tree_type
= TREE_TYPE (element
);
949 tree_type_x
= tree_type
;
951 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
952 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
953 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
955 if (TREE_TYPE (min
) != tree_type_x
)
956 min
= convert (tree_type_x
, min
);
957 if (TREE_TYPE (element
) != tree_type_x
)
958 element
= convert (tree_type_x
, element
);
960 item
= ffecom_2 (PLUS_EXPR
,
961 build_pointer_type (TREE_TYPE (array
)),
963 size_binop (MULT_EXPR
,
964 size_in_bytes (TREE_TYPE (array
)),
966 fold (build (MINUS_EXPR
,
972 item
= ffecom_1 (INDIRECT_REF
,
973 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
983 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
985 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
986 if (flag_bounds_check
)
987 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
989 if (element
== error_mark_node
)
992 /* Widen integral arithmetic as desired while preserving
994 tree_type
= TREE_TYPE (element
);
995 tree_type_x
= tree_type
;
997 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
998 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
999 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
1001 element
= convert (tree_type_x
, element
);
1003 item
= ffecom_2 (ARRAY_REF
,
1004 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
1013 /* This is like gcc's stabilize_reference -- in fact, most of the code
1014 comes from that -- but it handles the situation where the reference
1015 is going to have its subparts picked at, and it shouldn't change
1016 (or trigger extra invocations of functions in the subtrees) due to
1017 this. save_expr is a bit overzealous, because we don't need the
1018 entire thing calculated and saved like a temp. So, for DECLs, no
1019 change is needed, because these are stable aggregates, and ARRAY_REF
1020 and such might well be stable too, but for things like calculations,
1021 we do need to calculate a snapshot of a value before picking at it. */
1023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1025 ffecom_stabilize_aggregate_ (tree ref
)
1028 enum tree_code code
= TREE_CODE (ref
);
1035 /* No action is needed in this case. */
1041 case FIX_TRUNC_EXPR
:
1042 case FIX_FLOOR_EXPR
:
1043 case FIX_ROUND_EXPR
:
1045 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
1049 result
= build_nt (INDIRECT_REF
,
1050 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
1054 result
= build_nt (COMPONENT_REF
,
1055 stabilize_reference (TREE_OPERAND (ref
, 0)),
1056 TREE_OPERAND (ref
, 1));
1060 result
= build_nt (BIT_FIELD_REF
,
1061 stabilize_reference (TREE_OPERAND (ref
, 0)),
1062 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
1063 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
1067 result
= build_nt (ARRAY_REF
,
1068 stabilize_reference (TREE_OPERAND (ref
, 0)),
1069 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
1073 result
= build_nt (COMPOUND_EXPR
,
1074 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
1075 stabilize_reference (TREE_OPERAND (ref
, 1)));
1079 result
= build1 (INDIRECT_REF
, TREE_TYPE (ref
),
1080 save_expr (build1 (ADDR_EXPR
,
1081 build_pointer_type (TREE_TYPE (ref
)),
1087 return save_expr (ref
);
1090 return error_mark_node
;
1093 TREE_TYPE (result
) = TREE_TYPE (ref
);
1094 TREE_READONLY (result
) = TREE_READONLY (ref
);
1095 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
1096 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
1102 /* A rip-off of gcc's convert.c convert_to_complex function,
1103 reworked to handle complex implemented as C structures
1104 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1108 ffecom_convert_to_complex_ (tree type
, tree expr
)
1110 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1113 assert (TREE_CODE (type
) == RECORD_TYPE
);
1115 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1117 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1119 expr
= convert (subtype
, expr
);
1120 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1121 convert (subtype
, integer_zero_node
));
1124 if (form
== RECORD_TYPE
)
1126 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1127 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1131 expr
= save_expr (expr
);
1132 return ffecom_2 (COMPLEX_EXPR
,
1135 ffecom_1 (REALPART_EXPR
,
1136 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1139 ffecom_1 (IMAGPART_EXPR
,
1140 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1145 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1146 error ("pointer value used where a complex was expected");
1148 error ("aggregate value used where a complex was expected");
1150 return ffecom_2 (COMPLEX_EXPR
, type
,
1151 convert (subtype
, integer_zero_node
),
1152 convert (subtype
, integer_zero_node
));
1156 /* Like gcc's convert(), but crashes if widening might happen. */
1158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1160 ffecom_convert_narrow_ (type
, expr
)
1163 register tree e
= expr
;
1164 register enum tree_code code
= TREE_CODE (type
);
1166 if (type
== TREE_TYPE (e
)
1167 || TREE_CODE (e
) == ERROR_MARK
)
1169 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1170 return fold (build1 (NOP_EXPR
, type
, e
));
1171 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1172 || code
== ERROR_MARK
)
1173 return error_mark_node
;
1174 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1176 assert ("void value not ignored as it ought to be" == NULL
);
1177 return error_mark_node
;
1179 assert (code
!= VOID_TYPE
);
1180 if ((code
!= RECORD_TYPE
)
1181 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1182 assert ("converting COMPLEX to REAL" == NULL
);
1183 assert (code
!= ENUMERAL_TYPE
);
1184 if (code
== INTEGER_TYPE
)
1186 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1187 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1188 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1189 && (TYPE_PRECISION (type
)
1190 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1191 return fold (convert_to_integer (type
, e
));
1193 if (code
== POINTER_TYPE
)
1195 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1196 return fold (convert_to_pointer (type
, e
));
1198 if (code
== REAL_TYPE
)
1200 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1201 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1202 return fold (convert_to_real (type
, e
));
1204 if (code
== COMPLEX_TYPE
)
1206 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1207 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1208 return fold (convert_to_complex (type
, e
));
1210 if (code
== RECORD_TYPE
)
1212 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1213 /* Check that at least the first field name agrees. */
1214 assert (DECL_NAME (TYPE_FIELDS (type
))
1215 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1216 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1217 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1218 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1219 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1221 return fold (ffecom_convert_to_complex_ (type
, e
));
1224 assert ("conversion to non-scalar type requested" == NULL
);
1225 return error_mark_node
;
1229 /* Like gcc's convert(), but crashes if narrowing might happen. */
1231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1233 ffecom_convert_widen_ (type
, expr
)
1236 register tree e
= expr
;
1237 register enum tree_code code
= TREE_CODE (type
);
1239 if (type
== TREE_TYPE (e
)
1240 || TREE_CODE (e
) == ERROR_MARK
)
1242 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1243 return fold (build1 (NOP_EXPR
, type
, e
));
1244 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1245 || code
== ERROR_MARK
)
1246 return error_mark_node
;
1247 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1249 assert ("void value not ignored as it ought to be" == NULL
);
1250 return error_mark_node
;
1252 assert (code
!= VOID_TYPE
);
1253 if ((code
!= RECORD_TYPE
)
1254 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1255 assert ("narrowing COMPLEX to REAL" == NULL
);
1256 assert (code
!= ENUMERAL_TYPE
);
1257 if (code
== INTEGER_TYPE
)
1259 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1260 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1261 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1262 && (TYPE_PRECISION (type
)
1263 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1264 return fold (convert_to_integer (type
, e
));
1266 if (code
== POINTER_TYPE
)
1268 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1269 return fold (convert_to_pointer (type
, e
));
1271 if (code
== REAL_TYPE
)
1273 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1274 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1275 return fold (convert_to_real (type
, e
));
1277 if (code
== COMPLEX_TYPE
)
1279 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1280 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1281 return fold (convert_to_complex (type
, e
));
1283 if (code
== RECORD_TYPE
)
1285 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1286 /* Check that at least the first field name agrees. */
1287 assert (DECL_NAME (TYPE_FIELDS (type
))
1288 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1289 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1290 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1291 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1292 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1294 return fold (ffecom_convert_to_complex_ (type
, e
));
1297 assert ("conversion to non-scalar type requested" == NULL
);
1298 return error_mark_node
;
1302 /* Handles making a COMPLEX type, either the standard
1303 (but buggy?) gbe way, or the safer (but less elegant?)
1306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1308 ffecom_make_complex_type_ (tree subtype
)
1314 if (ffe_is_emulate_complex ())
1316 type
= make_node (RECORD_TYPE
);
1317 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1318 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1319 TYPE_FIELDS (type
) = realfield
;
1324 type
= make_node (COMPLEX_TYPE
);
1325 TREE_TYPE (type
) = subtype
;
1333 /* Chooses either the gbe or the f2c way to build a
1334 complex constant. */
1336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1338 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1342 if (ffe_is_emulate_complex ())
1344 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1345 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1346 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1350 bothparts
= build_complex (type
, realpart
, imagpart
);
1357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1359 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1362 tree
*plist
= &list
;
1363 tree trail
= NULL_TREE
; /* Append char length args here. */
1364 tree
*ptrail
= &trail
;
1369 tree wanted
= NULL_TREE
;
1370 static char zed
[] = "0";
1375 while (expr
!= NULL
)
1398 wanted
= ffecom_f2c_complex_type_node
;
1402 wanted
= ffecom_f2c_doublereal_type_node
;
1406 wanted
= ffecom_f2c_doublecomplex_type_node
;
1410 wanted
= ffecom_f2c_real_type_node
;
1414 wanted
= ffecom_f2c_integer_type_node
;
1418 wanted
= ffecom_f2c_longint_type_node
;
1422 assert ("bad argstring code" == NULL
);
1428 exprh
= ffebld_head (expr
);
1432 if ((wanted
== NULL_TREE
)
1435 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1436 [ffeinfo_kindtype (ffebld_info (exprh
))])
1437 == TYPE_MODE (wanted
))))
1439 = build_tree_list (NULL_TREE
,
1440 ffecom_arg_ptr_to_expr (exprh
,
1444 item
= ffecom_arg_expr (exprh
, &length
);
1445 item
= ffecom_convert_widen_ (wanted
, item
);
1448 item
= ffecom_1 (ADDR_EXPR
,
1449 build_pointer_type (TREE_TYPE (item
)),
1453 = build_tree_list (NULL_TREE
,
1457 plist
= &TREE_CHAIN (*plist
);
1458 expr
= ffebld_trail (expr
);
1459 if (length
!= NULL_TREE
)
1461 *ptrail
= build_tree_list (NULL_TREE
, length
);
1462 ptrail
= &TREE_CHAIN (*ptrail
);
1466 /* We've run out of args in the call; if the implementation expects
1467 more, supply null pointers for them, which the implementation can
1468 check to see if an arg was omitted. */
1470 while (*c
!= '\0' && *c
!= '0')
1475 assert ("missing arg to run-time routine!" == NULL
);
1490 assert ("bad arg string code" == NULL
);
1494 = build_tree_list (NULL_TREE
,
1496 plist
= &TREE_CHAIN (*plist
);
1505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1507 ffecom_widest_expr_type_ (ffebld list
)
1510 ffebld widest
= NULL
;
1512 ffetype widest_type
= NULL
;
1515 for (; list
!= NULL
; list
= ffebld_trail (list
))
1517 item
= ffebld_head (list
);
1520 if ((widest
!= NULL
)
1521 && (ffeinfo_basictype (ffebld_info (item
))
1522 != ffeinfo_basictype (ffebld_info (widest
))))
1524 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1525 ffeinfo_kindtype (ffebld_info (item
)));
1526 if ((widest
== FFEINFO_kindtypeNONE
)
1527 || (ffetype_size (type
)
1528 > ffetype_size (widest_type
)))
1535 assert (widest
!= NULL
);
1536 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1537 [ffeinfo_kindtype (ffebld_info (widest
))];
1538 assert (t
!= NULL_TREE
);
1543 /* Check whether a partial overlap between two expressions is possible.
1545 Can *starting* to write a portion of expr1 change the value
1546 computed (perhaps already, *partially*) by expr2?
1548 Currently, this is a concern only for a COMPLEX expr1. But if it
1549 isn't in COMMON or local EQUIVALENCE, since we don't support
1550 aliasing of arguments, it isn't a concern. */
1553 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1558 switch (ffebld_op (expr1
))
1560 case FFEBLD_opSYMTER
:
1561 sym
= ffebld_symter (expr1
);
1564 case FFEBLD_opARRAYREF
:
1565 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1567 sym
= ffebld_symter (ffebld_left (expr1
));
1574 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1575 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1576 || ! (st
= ffesymbol_storage (sym
))
1577 || ! ffestorag_parent (st
)))
1580 /* It's in COMMON or local EQUIVALENCE. */
1585 /* Check whether dest and source might overlap. ffebld versions of these
1586 might or might not be passed, will be NULL if not.
1588 The test is really whether source_tree is modifiable and, if modified,
1589 might overlap destination such that the value(s) in the destination might
1590 change before it is finally modified. dest_* are the canonized
1591 destination itself. */
1593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1595 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1596 tree source_tree
, ffebld source UNUSED
,
1604 if (source_tree
== NULL_TREE
)
1607 switch (TREE_CODE (source_tree
))
1610 case IDENTIFIER_NODE
:
1621 case TRUNC_DIV_EXPR
:
1623 case FLOOR_DIV_EXPR
:
1624 case ROUND_DIV_EXPR
:
1625 case TRUNC_MOD_EXPR
:
1627 case FLOOR_MOD_EXPR
:
1628 case ROUND_MOD_EXPR
:
1630 case EXACT_DIV_EXPR
:
1631 case FIX_TRUNC_EXPR
:
1633 case FIX_FLOOR_EXPR
:
1634 case FIX_ROUND_EXPR
:
1649 case BIT_ANDTC_EXPR
:
1651 case TRUTH_ANDIF_EXPR
:
1652 case TRUTH_ORIF_EXPR
:
1653 case TRUTH_AND_EXPR
:
1655 case TRUTH_XOR_EXPR
:
1656 case TRUTH_NOT_EXPR
:
1672 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1673 TREE_OPERAND (source_tree
, 1), NULL
,
1677 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1678 TREE_OPERAND (source_tree
, 0), NULL
,
1683 case NON_LVALUE_EXPR
:
1685 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1688 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1690 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1695 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1696 TREE_OPERAND (source_tree
, 1), NULL
,
1698 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1699 TREE_OPERAND (source_tree
, 2), NULL
,
1704 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1706 TREE_OPERAND (source_tree
, 0));
1710 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1713 source_decl
= source_tree
;
1714 source_offset
= bitsize_zero_node
;
1715 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1719 case REFERENCE_EXPR
:
1720 case PREDECREMENT_EXPR
:
1721 case PREINCREMENT_EXPR
:
1722 case POSTDECREMENT_EXPR
:
1723 case POSTINCREMENT_EXPR
:
1731 /* Come here when source_decl, source_offset, and source_size filled
1732 in appropriately. */
1734 if (source_decl
== NULL_TREE
)
1735 return FALSE
; /* No decl involved, so no overlap. */
1737 if (source_decl
!= dest_decl
)
1738 return FALSE
; /* Different decl, no overlap. */
1740 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1741 return TRUE
; /* Assignment into entire assumed-size
1742 array? Shouldn't happen.... */
1744 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1745 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1747 convert (TREE_TYPE (dest_offset
),
1749 convert (TREE_TYPE (dest_offset
),
1752 if (integer_onep (t
))
1753 return FALSE
; /* Destination precedes source. */
1756 || (source_size
== NULL_TREE
)
1757 || (TREE_CODE (source_size
) == ERROR_MARK
)
1758 || integer_zerop (source_size
))
1759 return TRUE
; /* No way to tell if dest follows source. */
1761 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1762 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1764 convert (TREE_TYPE (source_offset
),
1766 convert (TREE_TYPE (source_offset
),
1769 if (integer_onep (t
))
1770 return FALSE
; /* Destination follows source. */
1772 return TRUE
; /* Destination and source overlap. */
1776 /* Check whether dest might overlap any of a list of arguments or is
1777 in a COMMON area the callee might know about (and thus modify). */
1779 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1781 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1782 tree args
, tree callee_commons
,
1790 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1793 if (dest_decl
== NULL_TREE
)
1794 return FALSE
; /* Seems unlikely! */
1796 /* If the decl cannot be determined reliably, or if its in COMMON
1797 and the callee isn't known to not futz with COMMON via other
1798 means, overlap might happen. */
1800 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1801 || ((callee_commons
!= NULL_TREE
)
1802 && TREE_PUBLIC (dest_decl
)))
1805 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1807 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1808 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1809 arg
, NULL
, scalar_args
))
1817 /* Build a string for a variable name as used by NAMELIST. This means that
1818 if we're using the f2c library, we build an uppercase string, since
1821 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1823 ffecom_build_f2c_string_ (int i
, const char *s
)
1825 if (!ffe_is_f2c_library ())
1826 return build_string (i
, s
);
1835 if (((size_t) i
) > ARRAY_SIZE (space
))
1836 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1840 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1841 *q
= ffesrc_toupper (*p
);
1844 t
= build_string (i
, tmp
);
1846 if (((size_t) i
) > ARRAY_SIZE (space
))
1847 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1854 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1855 type to just get whatever the function returns), handling the
1856 f2c value-returning convention, if required, by prepending
1857 to the arglist a pointer to a temporary to receive the return value. */
1859 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1861 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1862 tree type
, tree args
, tree dest_tree
,
1863 ffebld dest
, bool *dest_used
, tree callee_commons
,
1864 bool scalar_args
, tree hook
)
1869 if (dest_used
!= NULL
)
1874 if ((dest_used
== NULL
)
1876 || (ffeinfo_basictype (ffebld_info (dest
))
1877 != FFEINFO_basictypeCOMPLEX
)
1878 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1879 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1880 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1885 tempvar
= ffecom_make_tempvar (ffecom_tree_type
1886 [FFEINFO_basictypeCOMPLEX
][kt
],
1887 FFETARGET_charactersizeNONE
,
1897 tempvar
= dest_tree
;
1902 = build_tree_list (NULL_TREE
,
1903 ffecom_1 (ADDR_EXPR
,
1904 build_pointer_type (TREE_TYPE (tempvar
)),
1906 TREE_CHAIN (item
) = args
;
1908 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1911 if (tempvar
!= dest_tree
)
1912 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1915 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1918 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1919 item
= ffecom_convert_narrow_ (type
, item
);
1925 /* Given two arguments, transform them and make a call to the given
1926 function via ffecom_call_. */
1928 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1930 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1931 tree type
, ffebld left
, ffebld right
,
1932 tree dest_tree
, ffebld dest
, bool *dest_used
,
1933 tree callee_commons
, bool scalar_args
, tree hook
)
1940 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1941 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1943 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1944 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1945 TREE_CHAIN (left_tree
) = right_tree
;
1947 if (left_length
!= NULL_TREE
)
1949 left_length
= build_tree_list (NULL_TREE
, left_length
);
1950 TREE_CHAIN (right_tree
) = left_length
;
1953 if (right_length
!= NULL_TREE
)
1955 right_length
= build_tree_list (NULL_TREE
, right_length
);
1956 if (left_length
!= NULL_TREE
)
1957 TREE_CHAIN (left_length
) = right_length
;
1959 TREE_CHAIN (right_tree
) = right_length
;
1962 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1963 dest_tree
, dest
, dest_used
, callee_commons
,
1968 /* Return ptr/length args for char subexpression
1970 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1971 subexpressions by constructing the appropriate trees for the ptr-to-
1972 character-text and length-of-character-text arguments in a calling
1975 Note that if with_null is TRUE, and the expression is an opCONTER,
1976 a null byte is appended to the string. */
1978 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1980 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1984 ffetargetCharacter1 val
;
1985 ffetargetCharacterSize newlen
;
1987 switch (ffebld_op (expr
))
1989 case FFEBLD_opCONTER
:
1990 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1991 newlen
= ffetarget_length_character1 (val
);
1994 /* Begin FFETARGET-NULL-KLUDGE. */
1998 *length
= build_int_2 (newlen
, 0);
1999 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2000 high
= build_int_2 (newlen
, 0);
2001 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
2002 item
= build_string (newlen
,
2003 ffetarget_text_character1 (val
));
2004 /* End FFETARGET-NULL-KLUDGE. */
2006 = build_type_variant
2010 (ffecom_f2c_ftnlen_type_node
,
2011 ffecom_f2c_ftnlen_one_node
,
2014 TREE_CONSTANT (item
) = 1;
2015 TREE_STATIC (item
) = 1;
2016 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
2020 case FFEBLD_opSYMTER
:
2022 ffesymbol s
= ffebld_symter (expr
);
2024 item
= ffesymbol_hook (s
).decl_tree
;
2025 if (item
== NULL_TREE
)
2027 s
= ffecom_sym_transform_ (s
);
2028 item
= ffesymbol_hook (s
).decl_tree
;
2030 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
2032 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
2033 *length
= ffesymbol_hook (s
).length_tree
;
2036 *length
= build_int_2 (ffesymbol_size (s
), 0);
2037 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2040 else if (item
== error_mark_node
)
2041 *length
= error_mark_node
;
2043 /* FFEINFO_kindFUNCTION. */
2044 *length
= NULL_TREE
;
2045 if (!ffesymbol_hook (s
).addr
2046 && (item
!= error_mark_node
))
2047 item
= ffecom_1 (ADDR_EXPR
,
2048 build_pointer_type (TREE_TYPE (item
)),
2053 case FFEBLD_opARRAYREF
:
2055 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2057 if (item
== error_mark_node
|| *length
== error_mark_node
)
2059 item
= *length
= error_mark_node
;
2063 item
= ffecom_arrayref_ (item
, expr
, 1);
2067 case FFEBLD_opSUBSTR
:
2071 ffebld thing
= ffebld_right (expr
);
2074 const char *char_name
;
2078 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
2079 start
= ffebld_head (thing
);
2080 thing
= ffebld_trail (thing
);
2081 assert (ffebld_trail (thing
) == NULL
);
2082 end
= ffebld_head (thing
);
2084 /* Determine name for pretty-printing range-check errors. */
2085 for (left_symter
= ffebld_left (expr
);
2086 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2087 left_symter
= ffebld_left (left_symter
))
2089 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2090 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2092 char_name
= "[expr?]";
2094 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2096 if (item
== error_mark_node
|| *length
== error_mark_node
)
2098 item
= *length
= error_mark_node
;
2102 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2104 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2112 end_tree
= ffecom_expr (end
);
2113 if (flag_bounds_check
)
2114 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2116 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2119 if (end_tree
== error_mark_node
)
2121 item
= *length
= error_mark_node
;
2130 start_tree
= ffecom_expr (start
);
2131 if (flag_bounds_check
)
2132 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2134 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2137 if (start_tree
== error_mark_node
)
2139 item
= *length
= error_mark_node
;
2143 start_tree
= ffecom_save_tree (start_tree
);
2145 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2147 ffecom_2 (MINUS_EXPR
,
2148 TREE_TYPE (start_tree
),
2150 ffecom_f2c_ftnlen_one_node
));
2154 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2155 ffecom_f2c_ftnlen_one_node
,
2156 ffecom_2 (MINUS_EXPR
,
2157 ffecom_f2c_ftnlen_type_node
,
2163 end_tree
= ffecom_expr (end
);
2164 if (flag_bounds_check
)
2165 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2167 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2170 if (end_tree
== error_mark_node
)
2172 item
= *length
= error_mark_node
;
2176 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2177 ffecom_f2c_ftnlen_one_node
,
2178 ffecom_2 (MINUS_EXPR
,
2179 ffecom_f2c_ftnlen_type_node
,
2180 end_tree
, start_tree
));
2186 case FFEBLD_opFUNCREF
:
2188 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2191 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2194 if (size
== FFETARGET_charactersizeNONE
)
2195 /* ~~Kludge alert! This should someday be fixed. */
2198 *length
= build_int_2 (size
, 0);
2199 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2201 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2202 == FFEINFO_whereINTRINSIC
)
2206 /* Invocation of an intrinsic returning CHARACTER*1. */
2207 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2211 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2212 assert (ix
!= FFECOM_gfrt
);
2213 item
= ffecom_gfrt_tree_ (ix
);
2218 item
= ffesymbol_hook (s
).decl_tree
;
2219 if (item
== NULL_TREE
)
2221 s
= ffecom_sym_transform_ (s
);
2222 item
= ffesymbol_hook (s
).decl_tree
;
2224 if (item
== error_mark_node
)
2226 item
= *length
= error_mark_node
;
2230 if (!ffesymbol_hook (s
).addr
)
2231 item
= ffecom_1_fn (item
);
2235 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
2237 tempvar
= ffebld_nonter_hook (expr
);
2240 tempvar
= ffecom_1 (ADDR_EXPR
,
2241 build_pointer_type (TREE_TYPE (tempvar
)),
2244 args
= build_tree_list (NULL_TREE
, tempvar
);
2246 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2247 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2250 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2251 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2253 TREE_CHAIN (TREE_CHAIN (args
))
2254 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2255 ffebld_right (expr
));
2259 TREE_CHAIN (TREE_CHAIN (args
))
2260 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2264 item
= ffecom_3s (CALL_EXPR
,
2265 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2266 item
, args
, NULL_TREE
);
2267 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2272 case FFEBLD_opCONVERT
:
2274 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2276 if (item
== error_mark_node
|| *length
== error_mark_node
)
2278 item
= *length
= error_mark_node
;
2282 if ((ffebld_size_known (ffebld_left (expr
))
2283 == FFETARGET_charactersizeNONE
)
2284 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2285 { /* Possible blank-padding needed, copy into
2292 tempvar
= ffecom_make_tempvar (char_type_node
,
2293 ffebld_size (expr
), -1);
2295 tempvar
= ffebld_nonter_hook (expr
);
2298 tempvar
= ffecom_1 (ADDR_EXPR
,
2299 build_pointer_type (TREE_TYPE (tempvar
)),
2302 newlen
= build_int_2 (ffebld_size (expr
), 0);
2303 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2305 args
= build_tree_list (NULL_TREE
, tempvar
);
2306 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2307 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2308 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2309 = build_tree_list (NULL_TREE
, *length
);
2311 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2312 TREE_SIDE_EFFECTS (item
) = 1;
2313 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2318 { /* Just truncate the length. */
2319 *length
= build_int_2 (ffebld_size (expr
), 0);
2320 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2325 assert ("bad op for single char arg expr" == NULL
);
2334 /* Check the size of the type to be sure it doesn't overflow the
2335 "portable" capacities of the compiler back end. `dummy' types
2336 can generally overflow the normal sizes as long as the computations
2337 themselves don't overflow. A particular target of the back end
2338 must still enforce its size requirements, though, and the back
2339 end takes care of this in stor-layout.c. */
2341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2343 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2345 if (TREE_CODE (type
) == ERROR_MARK
)
2348 if (TYPE_SIZE (type
) == NULL_TREE
)
2351 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2354 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2355 || (!dummy
&& (((TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2356 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2358 ffebad_start (FFEBAD_ARRAY_LARGE
);
2359 ffebad_string (ffesymbol_text (s
));
2360 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2363 return error_mark_node
;
2370 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2371 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2372 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2376 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2378 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2383 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2384 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2387 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2388 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2389 ffesymbol_text (s
));
2391 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2392 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2394 DECL_ARTIFICIAL (tlen
) = 1;
2398 if (sz
== FFETARGET_charactersizeNONE
)
2400 assert (tlen
!= NULL_TREE
);
2401 highval
= variable_size (tlen
);
2405 highval
= build_int_2 (sz
, 0);
2406 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2409 type
= build_array_type (type
,
2410 build_range_type (ffecom_f2c_ftnlen_type_node
,
2411 ffecom_f2c_ftnlen_one_node
,
2419 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2421 ffecomConcatList_ catlist;
2422 ffebld expr; // expr of CHARACTER basictype.
2423 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2424 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2426 Scans expr for character subexpressions, updates and returns catlist
2429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2430 static ffecomConcatList_
2431 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2432 ffetargetCharacterSize max
)
2434 ffetargetCharacterSize sz
;
2436 recurse
: /* :::::::::::::::::::: */
2441 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2442 return catlist
; /* Don't append any more items. */
2444 switch (ffebld_op (expr
))
2446 case FFEBLD_opCONTER
:
2447 case FFEBLD_opSYMTER
:
2448 case FFEBLD_opARRAYREF
:
2449 case FFEBLD_opFUNCREF
:
2450 case FFEBLD_opSUBSTR
:
2451 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2452 if they don't need to preserve it. */
2453 if (catlist
.count
== catlist
.max
)
2454 { /* Make a (larger) list. */
2458 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2459 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2460 newmax
* sizeof (newx
[0]));
2461 if (catlist
.max
!= 0)
2463 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2464 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2465 catlist
.max
* sizeof (newx
[0]));
2467 catlist
.max
= newmax
;
2468 catlist
.exprs
= newx
;
2470 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2471 catlist
.minlen
+= sz
;
2473 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2474 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2475 catlist
.maxlen
= sz
;
2477 catlist
.maxlen
+= sz
;
2478 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2479 { /* This item overlaps (or is beyond) the end
2480 of the destination. */
2481 switch (ffebld_op (expr
))
2483 case FFEBLD_opCONTER
:
2484 case FFEBLD_opSYMTER
:
2485 case FFEBLD_opARRAYREF
:
2486 case FFEBLD_opFUNCREF
:
2487 case FFEBLD_opSUBSTR
:
2488 /* ~~Do useful truncations here. */
2492 assert ("op changed or inconsistent switches!" == NULL
);
2496 catlist
.exprs
[catlist
.count
++] = expr
;
2499 case FFEBLD_opPAREN
:
2500 expr
= ffebld_left (expr
);
2501 goto recurse
; /* :::::::::::::::::::: */
2503 case FFEBLD_opCONCATENATE
:
2504 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2505 expr
= ffebld_right (expr
);
2506 goto recurse
; /* :::::::::::::::::::: */
2508 #if 0 /* Breaks passing small actual arg to larger
2509 dummy arg of sfunc */
2510 case FFEBLD_opCONVERT
:
2511 expr
= ffebld_left (expr
);
2513 ffetargetCharacterSize cmax
;
2515 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2517 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2520 goto recurse
; /* :::::::::::::::::::: */
2527 assert ("bad op in _gather_" == NULL
);
2533 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2535 ffecomConcatList_ catlist;
2536 ffecom_concat_list_kill_(catlist);
2538 Anything allocated within the list info is deallocated. */
2540 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2542 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2544 if (catlist
.max
!= 0)
2545 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2546 catlist
.max
* sizeof (catlist
.exprs
[0]));
2550 /* Make list of concatenated string exprs.
2552 Returns a flattened list of concatenated subexpressions given a
2553 tree of such expressions. */
2555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2556 static ffecomConcatList_
2557 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2559 ffecomConcatList_ catlist
;
2561 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2562 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2567 /* Provide some kind of useful info on member of aggregate area,
2568 since current g77/gcc technology does not provide debug info
2569 on these members. */
2571 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2573 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2574 tree member_type UNUSED
, ffetargetOffset offset
)
2584 for (type_id
= member_type
;
2585 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2588 switch (TREE_CODE (type_id
))
2592 type_id
= TYPE_NAME (type_id
);
2597 type_id
= TREE_TYPE (type_id
);
2601 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2602 type_id
= error_mark_node
;
2608 if (ffecom_transform_only_dummies_
2609 || !ffe_is_debug_kludge ())
2610 return; /* Can't do this yet, maybe later. */
2613 + strlen (aggr_type
)
2614 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2616 + IDENTIFIER_LENGTH (type_id
);
2619 if (((size_t) len
) >= ARRAY_SIZE (space
))
2620 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2624 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2626 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2629 value
= build_string (len
, buff
);
2631 = build_type_variant (build_array_type (char_type_node
,
2635 build_int_2 (strlen (buff
), 0))),
2637 decl
= build_decl (VAR_DECL
,
2638 ffecom_get_identifier_ (ffesymbol_text (member
)),
2640 TREE_CONSTANT (decl
) = 1;
2641 TREE_STATIC (decl
) = 1;
2642 DECL_INITIAL (decl
) = error_mark_node
;
2643 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2644 decl
= start_decl (decl
, FALSE
);
2645 finish_decl (decl
, value
, FALSE
);
2647 if (buff
!= &space
[0])
2648 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2652 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2654 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2655 int i; // entry# for this entrypoint (used by master fn)
2656 ffecom_do_entrypoint_(s,i);
2658 Makes a public entry point that calls our private master fn (already
2661 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2663 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2666 tree type
; /* Type of function. */
2667 tree multi_retval
; /* Var holding return value (union). */
2668 tree result
; /* Var holding result. */
2669 ffeinfoBasictype bt
;
2673 bool charfunc
; /* All entry points return same type
2675 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2676 bool multi
; /* Master fn has multiple return types. */
2677 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2679 int old_lineno
= lineno
;
2680 const char *old_input_filename
= input_filename
;
2682 input_filename
= ffesymbol_where_filename (fn
);
2683 lineno
= ffesymbol_where_filelinenum (fn
);
2685 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2686 return value, but also never calls resume_momentary, when starting an
2687 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2688 same thing. It shouldn't be a problem since start_function calls
2689 temporary_allocation, but it might be necessary. If it causes a problem
2690 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2691 comment appears twice in thist file. */
2693 suspend_momentary ();
2695 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2697 switch (ffecom_primary_entry_kind_
)
2699 case FFEINFO_kindFUNCTION
:
2701 /* Determine actual return type for function. */
2703 gt
= FFEGLOBAL_typeFUNC
;
2704 bt
= ffesymbol_basictype (fn
);
2705 kt
= ffesymbol_kindtype (fn
);
2706 if (bt
== FFEINFO_basictypeNONE
)
2708 ffeimplic_establish_symbol (fn
);
2709 if (ffesymbol_funcresult (fn
) != NULL
)
2710 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2711 bt
= ffesymbol_basictype (fn
);
2712 kt
= ffesymbol_kindtype (fn
);
2715 if (bt
== FFEINFO_basictypeCHARACTER
)
2716 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2717 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2718 && ffesymbol_is_f2c (fn
))
2719 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2721 charfunc
= cmplxfunc
= FALSE
;
2724 type
= ffecom_tree_fun_type_void
;
2725 else if (ffesymbol_is_f2c (fn
))
2726 type
= ffecom_tree_fun_type
[bt
][kt
];
2728 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2730 if ((type
== NULL_TREE
)
2731 || (TREE_TYPE (type
) == NULL_TREE
))
2732 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2734 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2737 case FFEINFO_kindSUBROUTINE
:
2738 gt
= FFEGLOBAL_typeSUBR
;
2739 bt
= FFEINFO_basictypeNONE
;
2740 kt
= FFEINFO_kindtypeNONE
;
2741 if (ffecom_is_altreturning_
)
2742 { /* Am _I_ altreturning? */
2743 for (item
= ffesymbol_dummyargs (fn
);
2745 item
= ffebld_trail (item
))
2747 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2749 altreturning
= TRUE
;
2754 type
= ffecom_tree_subr_type
;
2756 type
= ffecom_tree_fun_type_void
;
2759 type
= ffecom_tree_fun_type_void
;
2766 assert ("say what??" == NULL
);
2768 case FFEINFO_kindANY
:
2769 gt
= FFEGLOBAL_typeANY
;
2770 bt
= FFEINFO_basictypeNONE
;
2771 kt
= FFEINFO_kindtypeNONE
;
2772 type
= error_mark_node
;
2779 /* build_decl uses the current lineno and input_filename to set the decl
2780 source info. So, I've putzed with ffestd and ffeste code to update that
2781 source info to point to the appropriate statement just before calling
2782 ffecom_do_entrypoint (which calls this fn). */
2784 start_function (ffecom_get_external_identifier_ (fn
),
2786 0, /* nested/inline */
2787 1); /* TREE_PUBLIC */
2789 if (((g
= ffesymbol_global (fn
)) != NULL
)
2790 && ((ffeglobal_type (g
) == gt
)
2791 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2793 ffeglobal_set_hook (g
, current_function_decl
);
2796 /* Reset args in master arg list so they get retransitioned. */
2798 for (item
= ffecom_master_arglist_
;
2800 item
= ffebld_trail (item
))
2805 arg
= ffebld_head (item
);
2806 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2807 continue; /* Alternate return or some such thing. */
2808 s
= ffebld_symter (arg
);
2809 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2810 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2813 /* Build dummy arg list for this entry point. */
2815 yes
= suspend_momentary ();
2817 if (charfunc
|| cmplxfunc
)
2818 { /* Prepend arg for where result goes. */
2823 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2825 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2827 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2829 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2832 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2834 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2836 type
= build_pointer_type (type
);
2837 result
= build_decl (PARM_DECL
, result
, type
);
2839 push_parm_decl (result
);
2840 ffecom_func_result_
= result
;
2844 push_parm_decl (length
);
2845 ffecom_func_length_
= length
;
2849 result
= DECL_RESULT (current_function_decl
);
2851 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2853 resume_momentary (yes
);
2855 store_parm_decls (0);
2857 ffecom_start_compstmt ();
2858 /* Disallow temp vars at this level. */
2859 current_binding_level
->prep_state
= 2;
2861 /* Make local var to hold return type for multi-type master fn. */
2865 yes
= suspend_momentary ();
2867 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2869 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2870 ffecom_multi_type_node_
);
2871 multi_retval
= start_decl (multi_retval
, FALSE
);
2872 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2874 resume_momentary (yes
);
2877 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2879 /* Here we emit the actual code for the entry point. */
2885 tree arglist
= NULL_TREE
;
2886 tree
*plist
= &arglist
;
2892 /* Prepare actual arg list based on master arg list. */
2894 for (list
= ffecom_master_arglist_
;
2896 list
= ffebld_trail (list
))
2898 arg
= ffebld_head (list
);
2899 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2901 s
= ffebld_symter (arg
);
2902 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2903 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2904 actarg
= null_pointer_node
; /* We don't have this arg. */
2906 actarg
= ffesymbol_hook (s
).decl_tree
;
2907 *plist
= build_tree_list (NULL_TREE
, actarg
);
2908 plist
= &TREE_CHAIN (*plist
);
2911 /* This code appends the length arguments for character
2912 variables/arrays. */
2914 for (list
= ffecom_master_arglist_
;
2916 list
= ffebld_trail (list
))
2918 arg
= ffebld_head (list
);
2919 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2921 s
= ffebld_symter (arg
);
2922 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2923 continue; /* Only looking for CHARACTER arguments. */
2924 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2925 continue; /* Only looking for variables and arrays. */
2926 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2927 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2928 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2930 actarg
= ffesymbol_hook (s
).length_tree
;
2931 *plist
= build_tree_list (NULL_TREE
, actarg
);
2932 plist
= &TREE_CHAIN (*plist
);
2935 /* Prepend character-value return info to actual arg list. */
2939 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2940 TREE_CHAIN (prepend
)
2941 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2942 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2946 /* Prepend multi-type return value to actual arg list. */
2951 = build_tree_list (NULL_TREE
,
2952 ffecom_1 (ADDR_EXPR
,
2953 build_pointer_type (TREE_TYPE (multi_retval
)),
2955 TREE_CHAIN (prepend
) = arglist
;
2959 /* Prepend my entry-point number to the actual arg list. */
2961 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2962 TREE_CHAIN (prepend
) = arglist
;
2965 /* Build the call to the master function. */
2967 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2968 call
= ffecom_3s (CALL_EXPR
,
2969 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2970 master_fn
, arglist
, NULL_TREE
);
2972 /* Decide whether the master function is a function or subroutine, and
2973 handle the return value for my entry point. */
2975 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2978 expand_expr_stmt (call
);
2979 expand_null_return ();
2981 else if (multi
&& cmplxfunc
)
2983 expand_expr_stmt (call
);
2985 = ffecom_1 (INDIRECT_REF
,
2986 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2988 result
= ffecom_modify (NULL_TREE
, result
,
2989 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2991 ffecom_multi_fields_
[bt
][kt
]));
2992 expand_expr_stmt (result
);
2993 expand_null_return ();
2997 expand_expr_stmt (call
);
2999 = ffecom_modify (NULL_TREE
, result
,
3000 convert (TREE_TYPE (result
),
3001 ffecom_2 (COMPONENT_REF
,
3002 ffecom_tree_type
[bt
][kt
],
3004 ffecom_multi_fields_
[bt
][kt
])));
3005 expand_return (result
);
3010 = ffecom_1 (INDIRECT_REF
,
3011 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
3013 result
= ffecom_modify (NULL_TREE
, result
, call
);
3014 expand_expr_stmt (result
);
3015 expand_null_return ();
3019 result
= ffecom_modify (NULL_TREE
,
3021 convert (TREE_TYPE (result
),
3023 expand_return (result
);
3029 ffecom_end_compstmt ();
3031 finish_function (0);
3033 lineno
= old_lineno
;
3034 input_filename
= old_input_filename
;
3036 ffecom_doing_entry_
= FALSE
;
3040 /* Transform expr into gcc tree with possible destination
3042 Recursive descent on expr while making corresponding tree nodes and
3043 attaching type info and such. If destination supplied and compatible
3044 with temporary that would be made in certain cases, temporary isn't
3045 made, destination used instead, and dest_used flag set TRUE. */
3047 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3049 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
3050 bool *dest_used
, bool assignp
, bool widenp
)
3055 ffeinfoBasictype bt
;
3058 tree dt
; /* decl_tree for an ffesymbol. */
3059 tree tree_type
, tree_type_x
;
3062 enum tree_code code
;
3064 assert (expr
!= NULL
);
3066 if (dest_used
!= NULL
)
3069 bt
= ffeinfo_basictype (ffebld_info (expr
));
3070 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3071 tree_type
= ffecom_tree_type
[bt
][kt
];
3073 /* Widen integral arithmetic as desired while preserving signedness. */
3074 tree_type_x
= NULL_TREE
;
3075 if (widenp
&& tree_type
3076 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
3077 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
3078 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
3080 switch (ffebld_op (expr
))
3082 case FFEBLD_opACCTER
:
3085 ffebit bits
= ffebld_accter_bits (expr
);
3086 ffetargetOffset source_offset
= 0;
3087 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
3090 assert (dest_offset
== 0
3091 || (bt
== FFEINFO_basictypeCHARACTER
3092 && kt
== FFEINFO_kindtypeCHARACTER1
));
3097 ffebldConstantUnion cu
;
3100 ffebldConstantArray ca
= ffebld_accter (expr
);
3102 ffebit_test (bits
, source_offset
, &value
, &length
);
3108 for (i
= 0; i
< length
; ++i
)
3110 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
3113 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3116 && dest_offset
!= 0)
3117 purpose
= build_int_2 (dest_offset
, 0);
3119 purpose
= NULL_TREE
;
3121 if (list
== NULL_TREE
)
3122 list
= item
= build_tree_list (purpose
, t
);
3125 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
3126 item
= TREE_CHAIN (item
);
3130 source_offset
+= length
;
3131 dest_offset
+= length
;
3135 item
= build_int_2 ((ffebld_accter_size (expr
)
3136 + ffebld_accter_pad (expr
)) - 1, 0);
3137 ffebit_kill (ffebld_accter_bits (expr
));
3138 TREE_TYPE (item
) = ffecom_integer_type_node
;
3142 build_range_type (ffecom_integer_type_node
,
3143 ffecom_integer_zero_node
,
3145 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3146 TREE_CONSTANT (list
) = 1;
3147 TREE_STATIC (list
) = 1;
3150 case FFEBLD_opARRTER
:
3155 if (ffebld_arrter_pad (expr
) == 0)
3159 assert (bt
== FFEINFO_basictypeCHARACTER
3160 && kt
== FFEINFO_kindtypeCHARACTER1
);
3162 /* Becomes PURPOSE first time through loop. */
3163 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3166 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3168 ffebldConstantUnion cu
3169 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3171 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3173 if (list
== NULL_TREE
)
3174 /* Assume item is PURPOSE first time through loop. */
3175 list
= item
= build_tree_list (item
, t
);
3178 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3179 item
= TREE_CHAIN (item
);
3184 item
= build_int_2 ((ffebld_arrter_size (expr
)
3185 + ffebld_arrter_pad (expr
)) - 1, 0);
3186 TREE_TYPE (item
) = ffecom_integer_type_node
;
3190 build_range_type (ffecom_integer_type_node
,
3191 ffecom_integer_zero_node
,
3193 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3194 TREE_CONSTANT (list
) = 1;
3195 TREE_STATIC (list
) = 1;
3198 case FFEBLD_opCONTER
:
3199 assert (ffebld_conter_pad (expr
) == 0);
3201 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3205 case FFEBLD_opSYMTER
:
3206 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3207 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3208 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3209 s
= ffebld_symter (expr
);
3210 t
= ffesymbol_hook (s
).decl_tree
;
3213 { /* ASSIGN'ed-label expr. */
3214 if (ffe_is_ugly_assign ())
3216 /* User explicitly wants ASSIGN'ed variables to be at the same
3217 memory address as the variables when used in non-ASSIGN
3218 contexts. That can make old, arcane, non-standard code
3219 work, but don't try to do it when a pointer wouldn't fit
3220 in the normal variable (take other approach, and warn,
3225 s
= ffecom_sym_transform_ (s
);
3226 t
= ffesymbol_hook (s
).decl_tree
;
3227 assert (t
!= NULL_TREE
);
3230 if (t
== error_mark_node
)
3233 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3234 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3236 if (ffesymbol_hook (s
).addr
)
3237 t
= ffecom_1 (INDIRECT_REF
,
3238 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3242 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3244 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3245 FFEBAD_severityWARNING
);
3246 ffebad_string (ffesymbol_text (s
));
3247 ffebad_here (0, ffesymbol_where_line (s
),
3248 ffesymbol_where_column (s
));
3253 /* Don't use the normal variable's tree for ASSIGN, though mark
3254 it as in the system header (housekeeping). Use an explicit,
3255 specially created sibling that is known to be wide enough
3256 to hold pointers to labels. */
3259 && TREE_CODE (t
) == VAR_DECL
)
3260 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3262 t
= ffesymbol_hook (s
).assign_tree
;
3265 s
= ffecom_sym_transform_assign_ (s
);
3266 t
= ffesymbol_hook (s
).assign_tree
;
3267 assert (t
!= NULL_TREE
);
3274 s
= ffecom_sym_transform_ (s
);
3275 t
= ffesymbol_hook (s
).decl_tree
;
3276 assert (t
!= NULL_TREE
);
3278 if (ffesymbol_hook (s
).addr
)
3279 t
= ffecom_1 (INDIRECT_REF
,
3280 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3284 case FFEBLD_opARRAYREF
:
3285 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3287 case FFEBLD_opUPLUS
:
3288 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3289 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3291 case FFEBLD_opPAREN
:
3292 /* ~~~Make sure Fortran rules respected here */
3293 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3294 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3296 case FFEBLD_opUMINUS
:
3297 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3300 tree_type
= tree_type_x
;
3301 left
= convert (tree_type
, left
);
3303 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3306 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3307 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3310 tree_type
= tree_type_x
;
3311 left
= convert (tree_type
, left
);
3312 right
= convert (tree_type
, right
);
3314 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3316 case FFEBLD_opSUBTRACT
:
3317 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3318 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3321 tree_type
= tree_type_x
;
3322 left
= convert (tree_type
, left
);
3323 right
= convert (tree_type
, right
);
3325 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3327 case FFEBLD_opMULTIPLY
:
3328 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3329 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3332 tree_type
= tree_type_x
;
3333 left
= convert (tree_type
, left
);
3334 right
= convert (tree_type
, right
);
3336 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3338 case FFEBLD_opDIVIDE
:
3339 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3340 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3343 tree_type
= tree_type_x
;
3344 left
= convert (tree_type
, left
);
3345 right
= convert (tree_type
, right
);
3347 return ffecom_tree_divide_ (tree_type
, left
, right
,
3348 dest_tree
, dest
, dest_used
,
3349 ffebld_nonter_hook (expr
));
3351 case FFEBLD_opPOWER
:
3353 ffebld left
= ffebld_left (expr
);
3354 ffebld right
= ffebld_right (expr
);
3356 ffeinfoKindtype rtkt
;
3357 ffeinfoKindtype ltkt
;
3359 switch (ffeinfo_basictype (ffebld_info (right
)))
3361 case FFEINFO_basictypeINTEGER
:
3364 item
= ffecom_expr_power_integer_ (expr
);
3365 if (item
!= NULL_TREE
)
3369 rtkt
= FFEINFO_kindtypeINTEGER1
;
3370 switch (ffeinfo_basictype (ffebld_info (left
)))
3372 case FFEINFO_basictypeINTEGER
:
3373 if ((ffeinfo_kindtype (ffebld_info (left
))
3374 == FFEINFO_kindtypeINTEGER4
)
3375 || (ffeinfo_kindtype (ffebld_info (right
))
3376 == FFEINFO_kindtypeINTEGER4
))
3378 code
= FFECOM_gfrtPOW_QQ
;
3379 ltkt
= FFEINFO_kindtypeINTEGER4
;
3380 rtkt
= FFEINFO_kindtypeINTEGER4
;
3384 code
= FFECOM_gfrtPOW_II
;
3385 ltkt
= FFEINFO_kindtypeINTEGER1
;
3389 case FFEINFO_basictypeREAL
:
3390 if (ffeinfo_kindtype (ffebld_info (left
))
3391 == FFEINFO_kindtypeREAL1
)
3393 code
= FFECOM_gfrtPOW_RI
;
3394 ltkt
= FFEINFO_kindtypeREAL1
;
3398 code
= FFECOM_gfrtPOW_DI
;
3399 ltkt
= FFEINFO_kindtypeREAL2
;
3403 case FFEINFO_basictypeCOMPLEX
:
3404 if (ffeinfo_kindtype (ffebld_info (left
))
3405 == FFEINFO_kindtypeREAL1
)
3407 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3408 ltkt
= FFEINFO_kindtypeREAL1
;
3412 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3413 ltkt
= FFEINFO_kindtypeREAL2
;
3418 assert ("bad pow_*i" == NULL
);
3419 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3420 ltkt
= FFEINFO_kindtypeREAL1
;
3423 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3424 left
= ffeexpr_convert (left
, NULL
, NULL
,
3425 ffeinfo_basictype (ffebld_info (left
)),
3427 FFETARGET_charactersizeNONE
,
3428 FFEEXPR_contextLET
);
3429 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3430 right
= ffeexpr_convert (right
, NULL
, NULL
,
3431 FFEINFO_basictypeINTEGER
,
3433 FFETARGET_charactersizeNONE
,
3434 FFEEXPR_contextLET
);
3437 case FFEINFO_basictypeREAL
:
3438 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3439 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3440 FFEINFO_kindtypeREALDOUBLE
, 0,
3441 FFETARGET_charactersizeNONE
,
3442 FFEEXPR_contextLET
);
3443 if (ffeinfo_kindtype (ffebld_info (right
))
3444 == FFEINFO_kindtypeREAL1
)
3445 right
= ffeexpr_convert (right
, NULL
, NULL
,
3446 FFEINFO_basictypeREAL
,
3447 FFEINFO_kindtypeREALDOUBLE
, 0,
3448 FFETARGET_charactersizeNONE
,
3449 FFEEXPR_contextLET
);
3450 code
= FFECOM_gfrtPOW_DD
;
3453 case FFEINFO_basictypeCOMPLEX
:
3454 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3455 left
= ffeexpr_convert (left
, NULL
, NULL
,
3456 FFEINFO_basictypeCOMPLEX
,
3457 FFEINFO_kindtypeREALDOUBLE
, 0,
3458 FFETARGET_charactersizeNONE
,
3459 FFEEXPR_contextLET
);
3460 if (ffeinfo_kindtype (ffebld_info (right
))
3461 == FFEINFO_kindtypeREAL1
)
3462 right
= ffeexpr_convert (right
, NULL
, NULL
,
3463 FFEINFO_basictypeCOMPLEX
,
3464 FFEINFO_kindtypeREALDOUBLE
, 0,
3465 FFETARGET_charactersizeNONE
,
3466 FFEEXPR_contextLET
);
3467 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3471 assert ("bad pow_x*" == NULL
);
3472 code
= FFECOM_gfrtPOW_II
;
3475 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3476 ffecom_gfrt_kindtype (code
),
3477 (ffe_is_f2c_library ()
3478 && ffecom_gfrt_complex_
[code
]),
3479 tree_type
, left
, right
,
3480 dest_tree
, dest
, dest_used
,
3482 ffebld_nonter_hook (expr
));
3488 case FFEINFO_basictypeLOGICAL
:
3489 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3490 return convert (tree_type
, item
);
3492 case FFEINFO_basictypeINTEGER
:
3493 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3494 ffecom_expr (ffebld_left (expr
)));
3497 assert ("NOT bad basictype" == NULL
);
3499 case FFEINFO_basictypeANY
:
3500 return error_mark_node
;
3504 case FFEBLD_opFUNCREF
:
3505 assert (ffeinfo_basictype (ffebld_info (expr
))
3506 != FFEINFO_basictypeCHARACTER
);
3508 case FFEBLD_opSUBRREF
:
3509 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3510 == FFEINFO_whereINTRINSIC
)
3511 { /* Invocation of an intrinsic. */
3512 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3516 s
= ffebld_symter (ffebld_left (expr
));
3517 dt
= ffesymbol_hook (s
).decl_tree
;
3518 if (dt
== NULL_TREE
)
3520 s
= ffecom_sym_transform_ (s
);
3521 dt
= ffesymbol_hook (s
).decl_tree
;
3523 if (dt
== error_mark_node
)
3526 if (ffesymbol_hook (s
).addr
)
3529 item
= ffecom_1_fn (dt
);
3531 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3532 args
= ffecom_list_expr (ffebld_right (expr
));
3534 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3536 if (args
== error_mark_node
)
3537 return error_mark_node
;
3539 item
= ffecom_call_ (item
, kt
,
3540 ffesymbol_is_f2c (s
)
3541 && (bt
== FFEINFO_basictypeCOMPLEX
)
3542 && (ffesymbol_where (s
)
3543 != FFEINFO_whereCONSTANT
),
3546 dest_tree
, dest
, dest_used
,
3547 error_mark_node
, FALSE
,
3548 ffebld_nonter_hook (expr
));
3549 TREE_SIDE_EFFECTS (item
) = 1;
3555 case FFEINFO_basictypeLOGICAL
:
3557 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3558 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3559 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3560 return convert (tree_type
, item
);
3562 case FFEINFO_basictypeINTEGER
:
3563 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3564 ffecom_expr (ffebld_left (expr
)),
3565 ffecom_expr (ffebld_right (expr
)));
3568 assert ("AND bad basictype" == NULL
);
3570 case FFEINFO_basictypeANY
:
3571 return error_mark_node
;
3578 case FFEINFO_basictypeLOGICAL
:
3580 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3581 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3582 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3583 return convert (tree_type
, item
);
3585 case FFEINFO_basictypeINTEGER
:
3586 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3587 ffecom_expr (ffebld_left (expr
)),
3588 ffecom_expr (ffebld_right (expr
)));
3591 assert ("OR bad basictype" == NULL
);
3593 case FFEINFO_basictypeANY
:
3594 return error_mark_node
;
3602 case FFEINFO_basictypeLOGICAL
:
3604 = ffecom_2 (NE_EXPR
, integer_type_node
,
3605 ffecom_expr (ffebld_left (expr
)),
3606 ffecom_expr (ffebld_right (expr
)));
3607 return convert (tree_type
, ffecom_truth_value (item
));
3609 case FFEINFO_basictypeINTEGER
:
3610 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3611 ffecom_expr (ffebld_left (expr
)),
3612 ffecom_expr (ffebld_right (expr
)));
3615 assert ("XOR/NEQV bad basictype" == NULL
);
3617 case FFEINFO_basictypeANY
:
3618 return error_mark_node
;
3625 case FFEINFO_basictypeLOGICAL
:
3627 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3628 ffecom_expr (ffebld_left (expr
)),
3629 ffecom_expr (ffebld_right (expr
)));
3630 return convert (tree_type
, ffecom_truth_value (item
));
3632 case FFEINFO_basictypeINTEGER
:
3634 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3635 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3636 ffecom_expr (ffebld_left (expr
)),
3637 ffecom_expr (ffebld_right (expr
))));
3640 assert ("EQV bad basictype" == NULL
);
3642 case FFEINFO_basictypeANY
:
3643 return error_mark_node
;
3647 case FFEBLD_opCONVERT
:
3648 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3649 return error_mark_node
;
3653 case FFEINFO_basictypeLOGICAL
:
3654 case FFEINFO_basictypeINTEGER
:
3655 case FFEINFO_basictypeREAL
:
3656 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3658 case FFEINFO_basictypeCOMPLEX
:
3659 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3661 case FFEINFO_basictypeINTEGER
:
3662 case FFEINFO_basictypeLOGICAL
:
3663 case FFEINFO_basictypeREAL
:
3664 item
= ffecom_expr (ffebld_left (expr
));
3665 if (item
== error_mark_node
)
3666 return error_mark_node
;
3667 /* convert() takes care of converting to the subtype first,
3668 at least in gcc-2.7.2. */
3669 item
= convert (tree_type
, item
);
3672 case FFEINFO_basictypeCOMPLEX
:
3673 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3676 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3678 case FFEINFO_basictypeANY
:
3679 return error_mark_node
;
3684 assert ("CONVERT bad basictype" == NULL
);
3686 case FFEINFO_basictypeANY
:
3687 return error_mark_node
;
3693 goto relational
; /* :::::::::::::::::::: */
3697 goto relational
; /* :::::::::::::::::::: */
3701 goto relational
; /* :::::::::::::::::::: */
3705 goto relational
; /* :::::::::::::::::::: */
3709 goto relational
; /* :::::::::::::::::::: */
3714 relational
: /* :::::::::::::::::::: */
3715 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3717 case FFEINFO_basictypeLOGICAL
:
3718 case FFEINFO_basictypeINTEGER
:
3719 case FFEINFO_basictypeREAL
:
3720 item
= ffecom_2 (code
, integer_type_node
,
3721 ffecom_expr (ffebld_left (expr
)),
3722 ffecom_expr (ffebld_right (expr
)));
3723 return convert (tree_type
, item
);
3725 case FFEINFO_basictypeCOMPLEX
:
3726 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3729 tree arg1
= ffecom_expr (ffebld_left (expr
));
3730 tree arg2
= ffecom_expr (ffebld_right (expr
));
3732 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3733 return error_mark_node
;
3735 arg1
= ffecom_save_tree (arg1
);
3736 arg2
= ffecom_save_tree (arg2
);
3738 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3740 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3741 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3745 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3746 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3750 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3751 ffecom_2 (EQ_EXPR
, integer_type_node
,
3752 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3753 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3754 ffecom_2 (EQ_EXPR
, integer_type_node
,
3755 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3756 ffecom_1 (IMAGPART_EXPR
, real_type
,
3758 if (code
== EQ_EXPR
)
3759 item
= ffecom_truth_value (item
);
3761 item
= ffecom_truth_value_invert (item
);
3762 return convert (tree_type
, item
);
3765 case FFEINFO_basictypeCHARACTER
:
3767 ffebld left
= ffebld_left (expr
);
3768 ffebld right
= ffebld_right (expr
);
3774 /* f2c run-time functions do the implicit blank-padding for us,
3775 so we don't usually have to implement blank-padding ourselves.
3776 (The exception is when we pass an argument to a separately
3777 compiled statement function -- if we know the arg is not the
3778 same length as the dummy, we must truncate or extend it. If
3779 we "inline" statement functions, that necessity goes away as
3782 Strip off the CONVERT operators that blank-pad. (Truncation by
3783 CONVERT shouldn't happen here, but it can happen in
3786 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3787 left
= ffebld_left (left
);
3788 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3789 right
= ffebld_left (right
);
3791 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3792 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3794 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3795 || right_tree
== error_mark_node
3796 || right_length
== error_mark_node
)
3797 return error_mark_node
;
3799 if ((ffebld_size_known (left
) == 1)
3800 && (ffebld_size_known (right
) == 1))
3803 = ffecom_1 (INDIRECT_REF
,
3804 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3807 = ffecom_1 (INDIRECT_REF
,
3808 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3812 = ffecom_2 (code
, integer_type_node
,
3813 ffecom_2 (ARRAY_REF
,
3814 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3817 ffecom_2 (ARRAY_REF
,
3818 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3824 item
= build_tree_list (NULL_TREE
, left_tree
);
3825 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3826 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3828 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3829 = build_tree_list (NULL_TREE
, right_length
);
3830 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3831 item
= ffecom_2 (code
, integer_type_node
,
3833 convert (TREE_TYPE (item
),
3834 integer_zero_node
));
3836 item
= convert (tree_type
, item
);
3842 assert ("relational bad basictype" == NULL
);
3844 case FFEINFO_basictypeANY
:
3845 return error_mark_node
;
3849 case FFEBLD_opPERCENT_LOC
:
3850 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3851 return convert (tree_type
, item
);
3855 case FFEBLD_opBOUNDS
:
3856 case FFEBLD_opREPEAT
:
3857 case FFEBLD_opLABTER
:
3858 case FFEBLD_opLABTOK
:
3859 case FFEBLD_opIMPDO
:
3860 case FFEBLD_opCONCATENATE
:
3861 case FFEBLD_opSUBSTR
:
3863 assert ("bad op" == NULL
);
3866 return error_mark_node
;
3870 assert ("didn't think anything got here anymore!!" == NULL
);
3872 switch (ffebld_arity (expr
))
3875 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3876 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3877 if (TREE_OPERAND (item
, 0) == error_mark_node
3878 || TREE_OPERAND (item
, 1) == error_mark_node
)
3879 return error_mark_node
;
3883 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3884 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3885 return error_mark_node
;
3897 /* Returns the tree that does the intrinsic invocation.
3899 Note: this function applies only to intrinsics returning
3900 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3903 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3905 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3906 ffebld dest
, bool *dest_used
)
3909 tree saved_expr1
; /* For those who need it. */
3910 tree saved_expr2
; /* For those who need it. */
3911 ffeinfoBasictype bt
;
3915 tree real_type
; /* REAL type corresponding to COMPLEX. */
3917 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3918 ffebld arg1
; /* For handy reference. */
3921 ffeintrinImp codegen_imp
;
3924 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3926 if (dest_used
!= NULL
)
3929 bt
= ffeinfo_basictype (ffebld_info (expr
));
3930 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3931 tree_type
= ffecom_tree_type
[bt
][kt
];
3935 arg1
= ffebld_head (list
);
3936 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3937 return error_mark_node
;
3938 if ((list
= ffebld_trail (list
)) != NULL
)
3940 arg2
= ffebld_head (list
);
3941 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3942 return error_mark_node
;
3943 if ((list
= ffebld_trail (list
)) != NULL
)
3945 arg3
= ffebld_head (list
);
3946 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3947 return error_mark_node
;
3956 arg1
= arg2
= arg3
= NULL
;
3958 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3959 args. This is used by the MAX/MIN expansions. */
3962 arg1_type
= ffecom_tree_type
3963 [ffeinfo_basictype (ffebld_info (arg1
))]
3964 [ffeinfo_kindtype (ffebld_info (arg1
))];
3966 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3969 /* There are several ways for each of the cases in the following switch
3970 statements to exit (from simplest to use to most complicated):
3972 break; (when expr_tree == NULL)
3974 A standard call is made to the specific intrinsic just as if it had been
3975 passed in as a dummy procedure and called as any old procedure. This
3976 method can produce slower code but in some cases it's the easiest way for
3977 now. However, if a (presumably faster) direct call is available,
3978 that is used, so this is the easiest way in many more cases now.
3980 gfrt = FFECOM_gfrtWHATEVER;
3983 gfrt contains the gfrt index of a library function to call, passing the
3984 argument(s) by value rather than by reference. Used when a more
3985 careful choice of library function is needed than that provided
3986 by the vanilla `break;'.
3990 The expr_tree has been completely set up and is ready to be returned
3991 as is. No further actions are taken. Use this when the tree is not
3992 in the simple form for one of the arity_n labels. */
3994 /* For info on how the switch statement cases were written, see the files
3995 enclosed in comments below the switch statement. */
3997 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3998 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3999 if (gfrt
== FFECOM_gfrt
)
4000 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
4002 switch (codegen_imp
)
4004 case FFEINTRIN_impABS
:
4005 case FFEINTRIN_impCABS
:
4006 case FFEINTRIN_impCDABS
:
4007 case FFEINTRIN_impDABS
:
4008 case FFEINTRIN_impIABS
:
4009 if (ffeinfo_basictype (ffebld_info (arg1
))
4010 == FFEINFO_basictypeCOMPLEX
)
4012 if (kt
== FFEINFO_kindtypeREAL1
)
4013 gfrt
= FFECOM_gfrtCABS
;
4014 else if (kt
== FFEINFO_kindtypeREAL2
)
4015 gfrt
= FFECOM_gfrtCDABS
;
4018 return ffecom_1 (ABS_EXPR
, tree_type
,
4019 convert (tree_type
, ffecom_expr (arg1
)));
4021 case FFEINTRIN_impACOS
:
4022 case FFEINTRIN_impDACOS
:
4025 case FFEINTRIN_impAIMAG
:
4026 case FFEINTRIN_impDIMAG
:
4027 case FFEINTRIN_impIMAGPART
:
4028 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4029 arg1_type
= TREE_TYPE (arg1_type
);
4031 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4035 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
4036 ffecom_expr (arg1
)));
4038 case FFEINTRIN_impAINT
:
4039 case FFEINTRIN_impDINT
:
4041 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
4042 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
4043 #else /* in the meantime, must use floor to avoid range problems with ints */
4044 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4045 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4048 ffecom_3 (COND_EXPR
, double_type_node
,
4050 (ffecom_2 (GE_EXPR
, integer_type_node
,
4053 ffecom_float_zero_
))),
4054 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4055 build_tree_list (NULL_TREE
,
4056 convert (double_type_node
,
4059 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4060 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4061 build_tree_list (NULL_TREE
,
4062 convert (double_type_node
,
4063 ffecom_1 (NEGATE_EXPR
,
4071 case FFEINTRIN_impANINT
:
4072 case FFEINTRIN_impDNINT
:
4073 #if 0 /* This way of doing it won't handle real
4074 numbers of large magnitudes. */
4075 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4076 expr_tree
= convert (tree_type
,
4077 convert (integer_type_node
,
4078 ffecom_3 (COND_EXPR
, tree_type
,
4083 ffecom_float_zero_
)),
4084 ffecom_2 (PLUS_EXPR
,
4087 ffecom_float_half_
),
4088 ffecom_2 (MINUS_EXPR
,
4091 ffecom_float_half_
))));
4093 #else /* So we instead call floor. */
4094 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4095 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4098 ffecom_3 (COND_EXPR
, double_type_node
,
4100 (ffecom_2 (GE_EXPR
, integer_type_node
,
4103 ffecom_float_zero_
))),
4104 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4105 build_tree_list (NULL_TREE
,
4106 convert (double_type_node
,
4107 ffecom_2 (PLUS_EXPR
,
4111 ffecom_float_half_
)))),
4113 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4114 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4115 build_tree_list (NULL_TREE
,
4116 convert (double_type_node
,
4117 ffecom_2 (MINUS_EXPR
,
4120 ffecom_float_half_
),
4127 case FFEINTRIN_impASIN
:
4128 case FFEINTRIN_impDASIN
:
4129 case FFEINTRIN_impATAN
:
4130 case FFEINTRIN_impDATAN
:
4131 case FFEINTRIN_impATAN2
:
4132 case FFEINTRIN_impDATAN2
:
4135 case FFEINTRIN_impCHAR
:
4136 case FFEINTRIN_impACHAR
:
4138 tempvar
= ffecom_make_tempvar (char_type_node
, 1, -1);
4140 tempvar
= ffebld_nonter_hook (expr
);
4144 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4146 expr_tree
= ffecom_modify (tmv
,
4147 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4149 convert (tmv
, ffecom_expr (arg1
)));
4151 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4154 expr_tree
= ffecom_1 (ADDR_EXPR
,
4155 build_pointer_type (TREE_TYPE (expr_tree
)),
4159 case FFEINTRIN_impCMPLX
:
4160 case FFEINTRIN_impDCMPLX
:
4163 convert (tree_type
, ffecom_expr (arg1
));
4165 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4167 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4168 convert (real_type
, ffecom_expr (arg1
)),
4170 ffecom_expr (arg2
)));
4172 case FFEINTRIN_impCOMPLEX
:
4174 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4176 ffecom_expr (arg2
));
4178 case FFEINTRIN_impCONJG
:
4179 case FFEINTRIN_impDCONJG
:
4183 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4184 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4186 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4187 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4188 ffecom_1 (NEGATE_EXPR
, real_type
,
4189 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4192 case FFEINTRIN_impCOS
:
4193 case FFEINTRIN_impCCOS
:
4194 case FFEINTRIN_impCDCOS
:
4195 case FFEINTRIN_impDCOS
:
4196 if (bt
== FFEINFO_basictypeCOMPLEX
)
4198 if (kt
== FFEINFO_kindtypeREAL1
)
4199 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4200 else if (kt
== FFEINFO_kindtypeREAL2
)
4201 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4205 case FFEINTRIN_impCOSH
:
4206 case FFEINTRIN_impDCOSH
:
4209 case FFEINTRIN_impDBLE
:
4210 case FFEINTRIN_impDFLOAT
:
4211 case FFEINTRIN_impDREAL
:
4212 case FFEINTRIN_impFLOAT
:
4213 case FFEINTRIN_impIDINT
:
4214 case FFEINTRIN_impIFIX
:
4215 case FFEINTRIN_impINT2
:
4216 case FFEINTRIN_impINT8
:
4217 case FFEINTRIN_impINT
:
4218 case FFEINTRIN_impLONG
:
4219 case FFEINTRIN_impREAL
:
4220 case FFEINTRIN_impSHORT
:
4221 case FFEINTRIN_impSNGL
:
4222 return convert (tree_type
, ffecom_expr (arg1
));
4224 case FFEINTRIN_impDIM
:
4225 case FFEINTRIN_impDDIM
:
4226 case FFEINTRIN_impIDIM
:
4227 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4228 ffecom_expr (arg1
)));
4229 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4230 ffecom_expr (arg2
)));
4232 ffecom_3 (COND_EXPR
, tree_type
,
4234 (ffecom_2 (GT_EXPR
, integer_type_node
,
4237 ffecom_2 (MINUS_EXPR
, tree_type
,
4240 convert (tree_type
, ffecom_float_zero_
));
4242 case FFEINTRIN_impDPROD
:
4244 ffecom_2 (MULT_EXPR
, tree_type
,
4245 convert (tree_type
, ffecom_expr (arg1
)),
4246 convert (tree_type
, ffecom_expr (arg2
)));
4248 case FFEINTRIN_impEXP
:
4249 case FFEINTRIN_impCDEXP
:
4250 case FFEINTRIN_impCEXP
:
4251 case FFEINTRIN_impDEXP
:
4252 if (bt
== FFEINFO_basictypeCOMPLEX
)
4254 if (kt
== FFEINFO_kindtypeREAL1
)
4255 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4256 else if (kt
== FFEINFO_kindtypeREAL2
)
4257 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4261 case FFEINTRIN_impICHAR
:
4262 case FFEINTRIN_impIACHAR
:
4263 #if 0 /* The simple approach. */
4264 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4266 = ffecom_1 (INDIRECT_REF
,
4267 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4270 = ffecom_2 (ARRAY_REF
,
4271 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4274 return convert (tree_type
, expr_tree
);
4275 #else /* The more interesting (and more optimal) approach. */
4276 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4277 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4280 convert (tree_type
, integer_zero_node
));
4284 case FFEINTRIN_impINDEX
:
4287 case FFEINTRIN_impLEN
:
4289 break; /* The simple approach. */
4291 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4294 case FFEINTRIN_impLGE
:
4295 case FFEINTRIN_impLGT
:
4296 case FFEINTRIN_impLLE
:
4297 case FFEINTRIN_impLLT
:
4300 case FFEINTRIN_impLOG
:
4301 case FFEINTRIN_impALOG
:
4302 case FFEINTRIN_impCDLOG
:
4303 case FFEINTRIN_impCLOG
:
4304 case FFEINTRIN_impDLOG
:
4305 if (bt
== FFEINFO_basictypeCOMPLEX
)
4307 if (kt
== FFEINFO_kindtypeREAL1
)
4308 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4309 else if (kt
== FFEINFO_kindtypeREAL2
)
4310 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4314 case FFEINTRIN_impLOG10
:
4315 case FFEINTRIN_impALOG10
:
4316 case FFEINTRIN_impDLOG10
:
4317 if (gfrt
!= FFECOM_gfrt
)
4318 break; /* Already picked one, stick with it. */
4320 if (kt
== FFEINFO_kindtypeREAL1
)
4321 gfrt
= FFECOM_gfrtALOG10
;
4322 else if (kt
== FFEINFO_kindtypeREAL2
)
4323 gfrt
= FFECOM_gfrtDLOG10
;
4326 case FFEINTRIN_impMAX
:
4327 case FFEINTRIN_impAMAX0
:
4328 case FFEINTRIN_impAMAX1
:
4329 case FFEINTRIN_impDMAX1
:
4330 case FFEINTRIN_impMAX0
:
4331 case FFEINTRIN_impMAX1
:
4332 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4333 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4335 arg1_type
= tree_type
;
4336 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4337 convert (arg1_type
, ffecom_expr (arg1
)),
4338 convert (arg1_type
, ffecom_expr (arg2
)));
4339 for (; list
!= NULL
; list
= ffebld_trail (list
))
4341 if ((ffebld_head (list
) == NULL
)
4342 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4344 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4347 ffecom_expr (ffebld_head (list
))));
4349 return convert (tree_type
, expr_tree
);
4351 case FFEINTRIN_impMIN
:
4352 case FFEINTRIN_impAMIN0
:
4353 case FFEINTRIN_impAMIN1
:
4354 case FFEINTRIN_impDMIN1
:
4355 case FFEINTRIN_impMIN0
:
4356 case FFEINTRIN_impMIN1
:
4357 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4358 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4360 arg1_type
= tree_type
;
4361 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4362 convert (arg1_type
, ffecom_expr (arg1
)),
4363 convert (arg1_type
, ffecom_expr (arg2
)));
4364 for (; list
!= NULL
; list
= ffebld_trail (list
))
4366 if ((ffebld_head (list
) == NULL
)
4367 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4369 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4372 ffecom_expr (ffebld_head (list
))));
4374 return convert (tree_type
, expr_tree
);
4376 case FFEINTRIN_impMOD
:
4377 case FFEINTRIN_impAMOD
:
4378 case FFEINTRIN_impDMOD
:
4379 if (bt
!= FFEINFO_basictypeREAL
)
4380 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4381 convert (tree_type
, ffecom_expr (arg1
)),
4382 convert (tree_type
, ffecom_expr (arg2
)));
4384 if (kt
== FFEINFO_kindtypeREAL1
)
4385 gfrt
= FFECOM_gfrtAMOD
;
4386 else if (kt
== FFEINFO_kindtypeREAL2
)
4387 gfrt
= FFECOM_gfrtDMOD
;
4390 case FFEINTRIN_impNINT
:
4391 case FFEINTRIN_impIDNINT
:
4393 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4394 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4396 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4397 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4399 convert (ffecom_integer_type_node
,
4400 ffecom_3 (COND_EXPR
, arg1_type
,
4402 (ffecom_2 (GE_EXPR
, integer_type_node
,
4405 ffecom_float_zero_
))),
4406 ffecom_2 (PLUS_EXPR
, arg1_type
,
4409 ffecom_float_half_
)),
4410 ffecom_2 (MINUS_EXPR
, arg1_type
,
4413 ffecom_float_half_
))));
4416 case FFEINTRIN_impSIGN
:
4417 case FFEINTRIN_impDSIGN
:
4418 case FFEINTRIN_impISIGN
:
4420 tree arg2_tree
= ffecom_expr (arg2
);
4424 (ffecom_1 (ABS_EXPR
, tree_type
,
4426 ffecom_expr (arg1
))));
4428 = ffecom_3 (COND_EXPR
, tree_type
,
4430 (ffecom_2 (GE_EXPR
, integer_type_node
,
4432 convert (TREE_TYPE (arg2_tree
),
4433 integer_zero_node
))),
4435 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4436 /* Make sure SAVE_EXPRs get referenced early enough. */
4438 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4439 convert (void_type_node
, saved_expr1
),
4444 case FFEINTRIN_impSIN
:
4445 case FFEINTRIN_impCDSIN
:
4446 case FFEINTRIN_impCSIN
:
4447 case FFEINTRIN_impDSIN
:
4448 if (bt
== FFEINFO_basictypeCOMPLEX
)
4450 if (kt
== FFEINFO_kindtypeREAL1
)
4451 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4452 else if (kt
== FFEINFO_kindtypeREAL2
)
4453 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4457 case FFEINTRIN_impSINH
:
4458 case FFEINTRIN_impDSINH
:
4461 case FFEINTRIN_impSQRT
:
4462 case FFEINTRIN_impCDSQRT
:
4463 case FFEINTRIN_impCSQRT
:
4464 case FFEINTRIN_impDSQRT
:
4465 if (bt
== FFEINFO_basictypeCOMPLEX
)
4467 if (kt
== FFEINFO_kindtypeREAL1
)
4468 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4469 else if (kt
== FFEINFO_kindtypeREAL2
)
4470 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4474 case FFEINTRIN_impTAN
:
4475 case FFEINTRIN_impDTAN
:
4476 case FFEINTRIN_impTANH
:
4477 case FFEINTRIN_impDTANH
:
4480 case FFEINTRIN_impREALPART
:
4481 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4482 arg1_type
= TREE_TYPE (arg1_type
);
4484 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4488 ffecom_1 (REALPART_EXPR
, arg1_type
,
4489 ffecom_expr (arg1
)));
4491 case FFEINTRIN_impIAND
:
4492 case FFEINTRIN_impAND
:
4493 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4495 ffecom_expr (arg1
)),
4497 ffecom_expr (arg2
)));
4499 case FFEINTRIN_impIOR
:
4500 case FFEINTRIN_impOR
:
4501 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4503 ffecom_expr (arg1
)),
4505 ffecom_expr (arg2
)));
4507 case FFEINTRIN_impIEOR
:
4508 case FFEINTRIN_impXOR
:
4509 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4511 ffecom_expr (arg1
)),
4513 ffecom_expr (arg2
)));
4515 case FFEINTRIN_impLSHIFT
:
4516 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4518 convert (integer_type_node
,
4519 ffecom_expr (arg2
)));
4521 case FFEINTRIN_impRSHIFT
:
4522 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4524 convert (integer_type_node
,
4525 ffecom_expr (arg2
)));
4527 case FFEINTRIN_impNOT
:
4528 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4530 case FFEINTRIN_impBIT_SIZE
:
4531 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4533 case FFEINTRIN_impBTEST
:
4535 ffetargetLogical1
true;
4536 ffetargetLogical1
false;
4540 ffetarget_logical1 (&true, TRUE
);
4541 ffetarget_logical1 (&false, FALSE
);
4543 true_tree
= convert (tree_type
, integer_one_node
);
4545 true_tree
= convert (tree_type
, build_int_2 (true, 0));
4547 false_tree
= convert (tree_type
, integer_zero_node
);
4549 false_tree
= convert (tree_type
, build_int_2 (false, 0));
4552 ffecom_3 (COND_EXPR
, tree_type
,
4554 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4555 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4557 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4560 convert (integer_type_node
,
4561 ffecom_expr (arg2
)))),
4563 integer_zero_node
))),
4568 case FFEINTRIN_impIBCLR
:
4570 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4572 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4573 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4576 convert (integer_type_node
,
4577 ffecom_expr (arg2
)))));
4579 case FFEINTRIN_impIBITS
:
4581 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4582 ffecom_expr (arg3
)));
4584 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4587 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4588 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4590 convert (integer_type_node
,
4591 ffecom_expr (arg2
))),
4593 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4594 ffecom_1 (BIT_NOT_EXPR
,
4597 integer_zero_node
)),
4598 ffecom_2 (MINUS_EXPR
,
4600 TYPE_SIZE (uns_type
),
4602 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4604 = ffecom_3 (COND_EXPR
, tree_type
,
4606 (ffecom_2 (NE_EXPR
, integer_type_node
,
4608 integer_zero_node
)),
4610 convert (tree_type
, integer_zero_node
));
4615 case FFEINTRIN_impIBSET
:
4617 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4619 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4620 convert (tree_type
, integer_one_node
),
4621 convert (integer_type_node
,
4622 ffecom_expr (arg2
))));
4624 case FFEINTRIN_impISHFT
:
4626 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4627 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4628 ffecom_expr (arg2
)));
4630 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4633 = ffecom_3 (COND_EXPR
, tree_type
,
4635 (ffecom_2 (GE_EXPR
, integer_type_node
,
4637 integer_zero_node
)),
4638 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4642 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4643 convert (uns_type
, arg1_tree
),
4644 ffecom_1 (NEGATE_EXPR
,
4647 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4649 = ffecom_3 (COND_EXPR
, tree_type
,
4651 (ffecom_2 (NE_EXPR
, integer_type_node
,
4653 TYPE_SIZE (uns_type
))),
4655 convert (tree_type
, integer_zero_node
));
4657 /* Make sure SAVE_EXPRs get referenced early enough. */
4659 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4660 convert (void_type_node
, arg1_tree
),
4661 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4662 convert (void_type_node
, arg2_tree
),
4667 case FFEINTRIN_impISHFTC
:
4669 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4670 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4671 ffecom_expr (arg2
)));
4672 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4673 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4679 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4682 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4683 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4684 convert (tree_type
, integer_zero_node
)),
4686 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4688 = ffecom_3 (COND_EXPR
, tree_type
,
4690 (ffecom_2 (NE_EXPR
, integer_type_node
,
4692 TYPE_SIZE (uns_type
))),
4694 convert (tree_type
, integer_zero_node
));
4696 mask_arg1
= ffecom_save_tree (mask_arg1
);
4698 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4700 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4702 masked_arg1
= ffecom_save_tree (masked_arg1
);
4704 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4706 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4707 convert (uns_type
, masked_arg1
),
4708 ffecom_1 (NEGATE_EXPR
,
4711 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4713 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4717 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4718 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4722 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4723 convert (uns_type
, masked_arg1
),
4724 ffecom_2 (MINUS_EXPR
,
4729 = ffecom_3 (COND_EXPR
, tree_type
,
4731 (ffecom_2 (LT_EXPR
, integer_type_node
,
4733 integer_zero_node
)),
4737 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4738 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4741 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4742 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4746 = ffecom_3 (COND_EXPR
, tree_type
,
4748 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4749 ffecom_2 (EQ_EXPR
, integer_type_node
,
4754 ffecom_2 (EQ_EXPR
, integer_type_node
,
4756 integer_zero_node
))),
4759 /* Make sure SAVE_EXPRs get referenced early enough. */
4761 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4762 convert (void_type_node
, arg1_tree
),
4763 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4764 convert (void_type_node
, arg2_tree
),
4765 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4766 convert (void_type_node
,
4768 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4769 convert (void_type_node
,
4773 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4774 convert (void_type_node
,
4780 case FFEINTRIN_impLOC
:
4782 tree arg1_tree
= ffecom_expr (arg1
);
4785 = convert (tree_type
,
4786 ffecom_1 (ADDR_EXPR
,
4787 build_pointer_type (TREE_TYPE (arg1_tree
)),
4792 case FFEINTRIN_impMVBITS
:
4797 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4800 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4804 tree arg5_plus_arg3
;
4806 arg2_tree
= convert (integer_type_node
,
4807 ffecom_expr (arg2
));
4808 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4809 ffecom_expr (arg3
)));
4810 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4811 arg4_type
= TREE_TYPE (arg4_tree
);
4813 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4814 ffecom_expr (arg1
)));
4816 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4817 ffecom_expr (arg5
)));
4820 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4821 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4822 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4825 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4826 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4827 ffecom_1 (BIT_NOT_EXPR
,
4831 integer_zero_node
)),
4835 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4839 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4840 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4842 integer_zero_node
)),
4844 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4846 = ffecom_3 (COND_EXPR
, arg4_type
,
4848 (ffecom_2 (NE_EXPR
, integer_type_node
,
4850 convert (TREE_TYPE (arg5_plus_arg3
),
4851 TYPE_SIZE (arg4_type
)))),
4853 convert (arg4_type
, integer_zero_node
));
4856 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4858 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4860 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4861 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4862 ffecom_1 (BIT_NOT_EXPR
,
4866 integer_zero_node
)),
4869 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4872 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4874 = ffecom_3 (COND_EXPR
, arg4_type
,
4876 (ffecom_2 (NE_EXPR
, integer_type_node
,
4878 convert (TREE_TYPE (arg3_tree
),
4879 integer_zero_node
))),
4883 = ffecom_3 (COND_EXPR
, arg4_type
,
4885 (ffecom_2 (NE_EXPR
, integer_type_node
,
4887 convert (TREE_TYPE (arg3_tree
),
4888 TYPE_SIZE (arg4_type
)))),
4893 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4896 /* Make sure SAVE_EXPRs get referenced early enough. */
4898 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4900 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4902 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4904 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4908 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4915 case FFEINTRIN_impDERF
:
4916 case FFEINTRIN_impERF
:
4917 case FFEINTRIN_impDERFC
:
4918 case FFEINTRIN_impERFC
:
4921 case FFEINTRIN_impIARGC
:
4922 /* extern int xargc; i__1 = xargc - 1; */
4923 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4925 convert (TREE_TYPE (ffecom_tree_xargc_
),
4929 case FFEINTRIN_impSIGNAL_func
:
4930 case FFEINTRIN_impSIGNAL_subr
:
4936 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4937 ffecom_expr (arg1
));
4938 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4939 build_pointer_type (TREE_TYPE (arg1_tree
)),
4942 /* Pass procedure as a pointer to it, anything else by value. */
4943 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4944 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4946 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4947 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4951 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4953 arg3_tree
= NULL_TREE
;
4955 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4956 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4957 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4960 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4961 ffecom_gfrt_kindtype (gfrt
),
4963 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4967 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4968 ffebld_nonter_hook (expr
));
4970 if (arg3_tree
!= NULL_TREE
)
4972 = ffecom_modify (NULL_TREE
, arg3_tree
,
4973 convert (TREE_TYPE (arg3_tree
),
4978 case FFEINTRIN_impALARM
:
4984 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4985 ffecom_expr (arg1
));
4986 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4987 build_pointer_type (TREE_TYPE (arg1_tree
)),
4990 /* Pass procedure as a pointer to it, anything else by value. */
4991 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4992 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4994 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4995 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4999 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5001 arg3_tree
= NULL_TREE
;
5003 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5004 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5005 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5008 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5009 ffecom_gfrt_kindtype (gfrt
),
5013 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5014 ffebld_nonter_hook (expr
));
5016 if (arg3_tree
!= NULL_TREE
)
5018 = ffecom_modify (NULL_TREE
, arg3_tree
,
5019 convert (TREE_TYPE (arg3_tree
),
5024 case FFEINTRIN_impCHDIR_subr
:
5025 case FFEINTRIN_impFDATE_subr
:
5026 case FFEINTRIN_impFGET_subr
:
5027 case FFEINTRIN_impFPUT_subr
:
5028 case FFEINTRIN_impGETCWD_subr
:
5029 case FFEINTRIN_impHOSTNM_subr
:
5030 case FFEINTRIN_impSYSTEM_subr
:
5031 case FFEINTRIN_impUNLINK_subr
:
5033 tree arg1_len
= integer_zero_node
;
5037 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5040 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5042 arg2_tree
= NULL_TREE
;
5044 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5045 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5046 TREE_CHAIN (arg1_tree
) = arg1_len
;
5049 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5050 ffecom_gfrt_kindtype (gfrt
),
5054 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5055 ffebld_nonter_hook (expr
));
5057 if (arg2_tree
!= NULL_TREE
)
5059 = ffecom_modify (NULL_TREE
, arg2_tree
,
5060 convert (TREE_TYPE (arg2_tree
),
5065 case FFEINTRIN_impEXIT
:
5069 expr_tree
= build_tree_list (NULL_TREE
,
5070 ffecom_1 (ADDR_EXPR
,
5072 (ffecom_integer_type_node
),
5073 integer_zero_node
));
5076 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5077 ffecom_gfrt_kindtype (gfrt
),
5081 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5082 ffebld_nonter_hook (expr
));
5084 case FFEINTRIN_impFLUSH
:
5086 gfrt
= FFECOM_gfrtFLUSH
;
5088 gfrt
= FFECOM_gfrtFLUSH1
;
5091 case FFEINTRIN_impCHMOD_subr
:
5092 case FFEINTRIN_impLINK_subr
:
5093 case FFEINTRIN_impRENAME_subr
:
5094 case FFEINTRIN_impSYMLNK_subr
:
5096 tree arg1_len
= integer_zero_node
;
5098 tree arg2_len
= integer_zero_node
;
5102 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5103 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5105 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5107 arg3_tree
= NULL_TREE
;
5109 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5110 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5111 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5112 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5113 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5114 TREE_CHAIN (arg2_tree
) = arg1_len
;
5115 TREE_CHAIN (arg1_len
) = arg2_len
;
5116 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5117 ffecom_gfrt_kindtype (gfrt
),
5121 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5122 ffebld_nonter_hook (expr
));
5123 if (arg3_tree
!= NULL_TREE
)
5124 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5125 convert (TREE_TYPE (arg3_tree
),
5130 case FFEINTRIN_impLSTAT_subr
:
5131 case FFEINTRIN_impSTAT_subr
:
5133 tree arg1_len
= integer_zero_node
;
5138 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5140 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5143 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5145 arg3_tree
= NULL_TREE
;
5147 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5148 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5149 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5150 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5151 TREE_CHAIN (arg2_tree
) = arg1_len
;
5152 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5153 ffecom_gfrt_kindtype (gfrt
),
5157 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5158 ffebld_nonter_hook (expr
));
5159 if (arg3_tree
!= NULL_TREE
)
5160 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5161 convert (TREE_TYPE (arg3_tree
),
5166 case FFEINTRIN_impFGETC_subr
:
5167 case FFEINTRIN_impFPUTC_subr
:
5171 tree arg2_len
= integer_zero_node
;
5174 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5175 ffecom_expr (arg1
));
5176 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5177 build_pointer_type (TREE_TYPE (arg1_tree
)),
5180 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5182 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5184 arg3_tree
= NULL_TREE
;
5186 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5187 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5188 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5189 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5190 TREE_CHAIN (arg2_tree
) = arg2_len
;
5192 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5193 ffecom_gfrt_kindtype (gfrt
),
5197 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5198 ffebld_nonter_hook (expr
));
5199 if (arg3_tree
!= NULL_TREE
)
5200 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5201 convert (TREE_TYPE (arg3_tree
),
5206 case FFEINTRIN_impFSTAT_subr
:
5212 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5213 ffecom_expr (arg1
));
5214 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5215 build_pointer_type (TREE_TYPE (arg1_tree
)),
5218 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5219 ffecom_ptr_to_expr (arg2
));
5222 arg3_tree
= NULL_TREE
;
5224 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5226 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5227 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5228 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5229 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5230 ffecom_gfrt_kindtype (gfrt
),
5234 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5235 ffebld_nonter_hook (expr
));
5236 if (arg3_tree
!= NULL_TREE
) {
5237 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5238 convert (TREE_TYPE (arg3_tree
),
5244 case FFEINTRIN_impKILL_subr
:
5250 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5251 ffecom_expr (arg1
));
5252 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5253 build_pointer_type (TREE_TYPE (arg1_tree
)),
5256 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5257 ffecom_expr (arg2
));
5258 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5259 build_pointer_type (TREE_TYPE (arg2_tree
)),
5263 arg3_tree
= NULL_TREE
;
5265 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5267 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5268 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5269 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5270 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5271 ffecom_gfrt_kindtype (gfrt
),
5275 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5276 ffebld_nonter_hook (expr
));
5277 if (arg3_tree
!= NULL_TREE
) {
5278 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5279 convert (TREE_TYPE (arg3_tree
),
5285 case FFEINTRIN_impCTIME_subr
:
5286 case FFEINTRIN_impTTYNAM_subr
:
5288 tree arg1_len
= integer_zero_node
;
5292 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5294 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5295 ffecom_f2c_longint_type_node
:
5296 ffecom_f2c_integer_type_node
),
5297 ffecom_expr (arg1
));
5298 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5299 build_pointer_type (TREE_TYPE (arg2_tree
)),
5302 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5303 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5304 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5305 TREE_CHAIN (arg1_len
) = arg2_tree
;
5306 TREE_CHAIN (arg1_tree
) = arg1_len
;
5309 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5310 ffecom_gfrt_kindtype (gfrt
),
5314 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5315 ffebld_nonter_hook (expr
));
5316 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5320 case FFEINTRIN_impIRAND
:
5321 case FFEINTRIN_impRAND
:
5322 /* Arg defaults to 0 (normal random case) */
5327 arg1_tree
= ffecom_integer_zero_node
;
5329 arg1_tree
= ffecom_expr (arg1
);
5330 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5332 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5333 build_pointer_type (TREE_TYPE (arg1_tree
)),
5335 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5337 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5338 ffecom_gfrt_kindtype (gfrt
),
5340 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5341 ffecom_f2c_integer_type_node
:
5342 ffecom_f2c_real_type_node
),
5344 dest_tree
, dest
, dest_used
,
5346 ffebld_nonter_hook (expr
));
5350 case FFEINTRIN_impFTELL_subr
:
5351 case FFEINTRIN_impUMASK_subr
:
5356 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5357 ffecom_expr (arg1
));
5358 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5359 build_pointer_type (TREE_TYPE (arg1_tree
)),
5363 arg2_tree
= NULL_TREE
;
5365 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5367 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5368 ffecom_gfrt_kindtype (gfrt
),
5371 build_tree_list (NULL_TREE
, arg1_tree
),
5372 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5374 ffebld_nonter_hook (expr
));
5375 if (arg2_tree
!= NULL_TREE
) {
5376 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5377 convert (TREE_TYPE (arg2_tree
),
5383 case FFEINTRIN_impCPU_TIME
:
5384 case FFEINTRIN_impSECOND_subr
:
5388 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5391 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5392 ffecom_gfrt_kindtype (gfrt
),
5396 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5397 ffebld_nonter_hook (expr
));
5400 = ffecom_modify (NULL_TREE
, arg1_tree
,
5401 convert (TREE_TYPE (arg1_tree
),
5406 case FFEINTRIN_impDTIME_subr
:
5407 case FFEINTRIN_impETIME_subr
:
5412 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5414 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5416 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5417 ffecom_gfrt_kindtype (gfrt
),
5420 build_tree_list (NULL_TREE
, arg1_tree
),
5421 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5423 ffebld_nonter_hook (expr
));
5424 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5425 convert (TREE_TYPE (result_tree
),
5430 /* Straightforward calls of libf2c routines: */
5431 case FFEINTRIN_impABORT
:
5432 case FFEINTRIN_impACCESS
:
5433 case FFEINTRIN_impBESJ0
:
5434 case FFEINTRIN_impBESJ1
:
5435 case FFEINTRIN_impBESJN
:
5436 case FFEINTRIN_impBESY0
:
5437 case FFEINTRIN_impBESY1
:
5438 case FFEINTRIN_impBESYN
:
5439 case FFEINTRIN_impCHDIR_func
:
5440 case FFEINTRIN_impCHMOD_func
:
5441 case FFEINTRIN_impDATE
:
5442 case FFEINTRIN_impDATE_AND_TIME
:
5443 case FFEINTRIN_impDBESJ0
:
5444 case FFEINTRIN_impDBESJ1
:
5445 case FFEINTRIN_impDBESJN
:
5446 case FFEINTRIN_impDBESY0
:
5447 case FFEINTRIN_impDBESY1
:
5448 case FFEINTRIN_impDBESYN
:
5449 case FFEINTRIN_impDTIME_func
:
5450 case FFEINTRIN_impETIME_func
:
5451 case FFEINTRIN_impFGETC_func
:
5452 case FFEINTRIN_impFGET_func
:
5453 case FFEINTRIN_impFNUM
:
5454 case FFEINTRIN_impFPUTC_func
:
5455 case FFEINTRIN_impFPUT_func
:
5456 case FFEINTRIN_impFSEEK
:
5457 case FFEINTRIN_impFSTAT_func
:
5458 case FFEINTRIN_impFTELL_func
:
5459 case FFEINTRIN_impGERROR
:
5460 case FFEINTRIN_impGETARG
:
5461 case FFEINTRIN_impGETCWD_func
:
5462 case FFEINTRIN_impGETENV
:
5463 case FFEINTRIN_impGETGID
:
5464 case FFEINTRIN_impGETLOG
:
5465 case FFEINTRIN_impGETPID
:
5466 case FFEINTRIN_impGETUID
:
5467 case FFEINTRIN_impGMTIME
:
5468 case FFEINTRIN_impHOSTNM_func
:
5469 case FFEINTRIN_impIDATE_unix
:
5470 case FFEINTRIN_impIDATE_vxt
:
5471 case FFEINTRIN_impIERRNO
:
5472 case FFEINTRIN_impISATTY
:
5473 case FFEINTRIN_impITIME
:
5474 case FFEINTRIN_impKILL_func
:
5475 case FFEINTRIN_impLINK_func
:
5476 case FFEINTRIN_impLNBLNK
:
5477 case FFEINTRIN_impLSTAT_func
:
5478 case FFEINTRIN_impLTIME
:
5479 case FFEINTRIN_impMCLOCK8
:
5480 case FFEINTRIN_impMCLOCK
:
5481 case FFEINTRIN_impPERROR
:
5482 case FFEINTRIN_impRENAME_func
:
5483 case FFEINTRIN_impSECNDS
:
5484 case FFEINTRIN_impSECOND_func
:
5485 case FFEINTRIN_impSLEEP
:
5486 case FFEINTRIN_impSRAND
:
5487 case FFEINTRIN_impSTAT_func
:
5488 case FFEINTRIN_impSYMLNK_func
:
5489 case FFEINTRIN_impSYSTEM_CLOCK
:
5490 case FFEINTRIN_impSYSTEM_func
:
5491 case FFEINTRIN_impTIME8
:
5492 case FFEINTRIN_impTIME_unix
:
5493 case FFEINTRIN_impTIME_vxt
:
5494 case FFEINTRIN_impUMASK_func
:
5495 case FFEINTRIN_impUNLINK_func
:
5498 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5499 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5500 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5501 case FFEINTRIN_impNONE
:
5502 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5503 fprintf (stderr
, "No %s implementation.\n",
5504 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5505 assert ("unimplemented intrinsic" == NULL
);
5506 return error_mark_node
;
5509 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5511 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5512 ffebld_right (expr
));
5514 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5515 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5517 expr_tree
, dest_tree
, dest
, dest_used
,
5519 ffebld_nonter_hook (expr
));
5521 /* See bottom of this file for f2c transforms used to determine
5522 many of the above implementations. The info seems to confuse
5523 Emacs's C mode indentation, which is why it's been moved to
5524 the bottom of this source file. */
5528 /* For power (exponentiation) where right-hand operand is type INTEGER,
5529 generate in-line code to do it the fast way (which, if the operand
5530 is a constant, might just mean a series of multiplies). */
5532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5534 ffecom_expr_power_integer_ (ffebld expr
)
5536 tree l
= ffecom_expr (ffebld_left (expr
));
5537 tree r
= ffecom_expr (ffebld_right (expr
));
5538 tree ltype
= TREE_TYPE (l
);
5539 tree rtype
= TREE_TYPE (r
);
5540 tree result
= NULL_TREE
;
5542 if (l
== error_mark_node
5543 || r
== error_mark_node
)
5544 return error_mark_node
;
5546 if (TREE_CODE (r
) == INTEGER_CST
)
5548 int sgn
= tree_int_cst_sgn (r
);
5551 return convert (ltype
, integer_one_node
);
5553 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5556 /* Reciprocal of integer is either 0, -1, or 1, so after
5557 calculating that (which we leave to the back end to do
5558 or not do optimally), don't bother with any multiplying. */
5560 result
= ffecom_tree_divide_ (ltype
,
5561 convert (ltype
, integer_one_node
),
5563 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5564 r
= ffecom_1 (NEGATE_EXPR
,
5567 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5568 result
= ffecom_1 (ABS_EXPR
, rtype
,
5572 /* Generate appropriate series of multiplies, preceded
5573 by divide if the exponent is negative. */
5579 l
= ffecom_tree_divide_ (ltype
,
5580 convert (ltype
, integer_one_node
),
5582 NULL_TREE
, NULL
, NULL
,
5583 ffebld_nonter_hook (expr
));
5584 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5585 assert (TREE_CODE (r
) == INTEGER_CST
);
5587 if (tree_int_cst_sgn (r
) < 0)
5588 { /* The "most negative" number. */
5589 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5590 ffecom_2 (RSHIFT_EXPR
, rtype
,
5594 l
= ffecom_2 (MULT_EXPR
, ltype
,
5602 if (TREE_INT_CST_LOW (r
) & 1)
5604 if (result
== NULL_TREE
)
5607 result
= ffecom_2 (MULT_EXPR
, ltype
,
5612 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5615 if (integer_zerop (r
))
5617 assert (TREE_CODE (r
) == INTEGER_CST
);
5620 l
= ffecom_2 (MULT_EXPR
, ltype
,
5627 /* Though rhs isn't a constant, in-line code cannot be expanded
5628 while transforming dummies
5629 because the back end cannot be easily convinced to generate
5630 stores (MODIFY_EXPR), handle temporaries, and so on before
5631 all the appropriate rtx's have been generated for things like
5632 dummy args referenced in rhs -- which doesn't happen until
5633 store_parm_decls() is called (expand_function_start, I believe,
5634 does the actual rtx-stuffing of PARM_DECLs).
5636 So, in this case, let the caller generate the call to the
5637 run-time-library function to evaluate the power for us. */
5639 if (ffecom_transform_only_dummies_
)
5642 /* Right-hand operand not a constant, expand in-line code to figure
5643 out how to do the multiplies, &c.
5645 The returned expression is expressed this way in GNU C, where l and
5648 ({ typeof (r) rtmp = r;
5649 typeof (l) ltmp = l;
5656 if ((basetypeof (l) == basetypeof (int))
5659 result = ((typeof (l)) 1) / ltmp;
5660 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5666 if ((basetypeof (l) != basetypeof (int))
5669 ltmp = ((typeof (l)) 1) / ltmp;
5673 rtmp = -(rtmp >> 1);
5681 if ((rtmp >>= 1) == 0)
5690 Note that some of the above is compile-time collapsable, such as
5691 the first part of the if statements that checks the base type of
5692 l against int. The if statements are phrased that way to suggest
5693 an easy way to generate the if/else constructs here, knowing that
5694 the back end should (and probably does) eliminate the resulting
5695 dead code (either the int case or the non-int case), something
5696 it couldn't do without the redundant phrasing, requiring explicit
5697 dead-code elimination here, which would be kind of difficult to
5704 tree basetypeof_l_is_int
;
5709 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5711 se
= expand_start_stmt_expr ();
5713 ffecom_start_compstmt ();
5716 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5717 FFETARGET_charactersizeNONE
, -1);
5718 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5719 FFETARGET_charactersizeNONE
, -1);
5720 result
= ffecom_make_tempvar ("power_res", ltype
,
5721 FFETARGET_charactersizeNONE
, -1);
5722 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5723 || TREE_CODE (ltype
) == RECORD_TYPE
)
5724 divide
= ffecom_make_tempvar ("power_div", ltype
,
5725 FFETARGET_charactersizeNONE
, -1);
5732 hook
= ffebld_nonter_hook (expr
);
5734 assert (TREE_CODE (hook
) == TREE_VEC
);
5735 assert (TREE_VEC_LENGTH (hook
) == 4);
5736 rtmp
= TREE_VEC_ELT (hook
, 0);
5737 ltmp
= TREE_VEC_ELT (hook
, 1);
5738 result
= TREE_VEC_ELT (hook
, 2);
5739 divide
= TREE_VEC_ELT (hook
, 3);
5740 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5741 || TREE_CODE (ltype
) == RECORD_TYPE
)
5748 expand_expr_stmt (ffecom_modify (void_type_node
,
5751 expand_expr_stmt (ffecom_modify (void_type_node
,
5754 expand_start_cond (ffecom_truth_value
5755 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5757 convert (rtype
, integer_zero_node
))),
5759 expand_expr_stmt (ffecom_modify (void_type_node
,
5761 convert (ltype
, integer_one_node
)));
5762 expand_start_else ();
5763 if (! integer_zerop (basetypeof_l_is_int
))
5765 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5768 integer_zero_node
)),
5770 expand_expr_stmt (ffecom_modify (void_type_node
,
5774 convert (ltype
, integer_one_node
),
5776 NULL_TREE
, NULL
, NULL
,
5778 expand_start_cond (ffecom_truth_value
5779 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5780 ffecom_2 (LT_EXPR
, integer_type_node
,
5783 integer_zero_node
)),
5784 ffecom_2 (EQ_EXPR
, integer_type_node
,
5785 ffecom_2 (BIT_AND_EXPR
,
5787 ffecom_1 (NEGATE_EXPR
,
5793 integer_zero_node
)))),
5795 expand_expr_stmt (ffecom_modify (void_type_node
,
5797 ffecom_1 (NEGATE_EXPR
,
5801 expand_start_else ();
5803 expand_expr_stmt (ffecom_modify (void_type_node
,
5805 convert (ltype
, integer_one_node
)));
5806 expand_start_cond (ffecom_truth_value
5807 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5808 ffecom_truth_value_invert
5809 (basetypeof_l_is_int
),
5810 ffecom_2 (LT_EXPR
, integer_type_node
,
5813 integer_zero_node
)))),
5815 expand_expr_stmt (ffecom_modify (void_type_node
,
5819 convert (ltype
, integer_one_node
),
5821 NULL_TREE
, NULL
, NULL
,
5823 expand_expr_stmt (ffecom_modify (void_type_node
,
5825 ffecom_1 (NEGATE_EXPR
, rtype
,
5827 expand_start_cond (ffecom_truth_value
5828 (ffecom_2 (LT_EXPR
, integer_type_node
,
5830 convert (rtype
, integer_zero_node
))),
5832 expand_expr_stmt (ffecom_modify (void_type_node
,
5834 ffecom_1 (NEGATE_EXPR
, rtype
,
5835 ffecom_2 (RSHIFT_EXPR
,
5838 integer_one_node
))));
5839 expand_expr_stmt (ffecom_modify (void_type_node
,
5841 ffecom_2 (MULT_EXPR
, ltype
,
5846 expand_start_loop (1);
5847 expand_start_cond (ffecom_truth_value
5848 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5850 convert (rtype
, integer_one_node
))),
5852 expand_expr_stmt (ffecom_modify (void_type_node
,
5854 ffecom_2 (MULT_EXPR
, ltype
,
5858 expand_exit_loop_if_false (NULL
,
5860 (ffecom_modify (rtype
,
5862 ffecom_2 (RSHIFT_EXPR
,
5865 integer_one_node
))));
5866 expand_expr_stmt (ffecom_modify (void_type_node
,
5868 ffecom_2 (MULT_EXPR
, ltype
,
5873 if (!integer_zerop (basetypeof_l_is_int
))
5875 expand_expr_stmt (result
);
5877 t
= ffecom_end_compstmt ();
5879 result
= expand_end_stmt_expr (se
);
5881 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5883 if (TREE_CODE (t
) == BLOCK
)
5885 /* Make a BIND_EXPR for the BLOCK already made. */
5886 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5887 NULL_TREE
, result
, t
);
5888 /* Remove the block from the tree at this point.
5889 It gets put back at the proper place
5890 when the BIND_EXPR is expanded. */
5901 /* ffecom_expr_transform_ -- Transform symbols in expr
5903 ffebld expr; // FFE expression.
5904 ffecom_expr_transform_ (expr);
5906 Recursive descent on expr while transforming any untransformed SYMTERs. */
5908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5910 ffecom_expr_transform_ (ffebld expr
)
5915 tail_recurse
: /* :::::::::::::::::::: */
5920 switch (ffebld_op (expr
))
5922 case FFEBLD_opSYMTER
:
5923 s
= ffebld_symter (expr
);
5924 t
= ffesymbol_hook (s
).decl_tree
;
5925 if ((t
== NULL_TREE
)
5926 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5927 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5928 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5930 s
= ffecom_sym_transform_ (s
);
5931 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5934 break; /* Ok if (t == NULL) here. */
5937 ffecom_expr_transform_ (ffebld_head (expr
));
5938 expr
= ffebld_trail (expr
);
5939 goto tail_recurse
; /* :::::::::::::::::::: */
5945 switch (ffebld_arity (expr
))
5948 ffecom_expr_transform_ (ffebld_left (expr
));
5949 expr
= ffebld_right (expr
);
5950 goto tail_recurse
; /* :::::::::::::::::::: */
5953 expr
= ffebld_left (expr
);
5954 goto tail_recurse
; /* :::::::::::::::::::: */
5964 /* Make a type based on info in live f2c.h file. */
5966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5968 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5972 case FFECOM_f2ccodeCHAR
:
5973 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5976 case FFECOM_f2ccodeSHORT
:
5977 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5980 case FFECOM_f2ccodeINT
:
5981 *type
= make_signed_type (INT_TYPE_SIZE
);
5984 case FFECOM_f2ccodeLONG
:
5985 *type
= make_signed_type (LONG_TYPE_SIZE
);
5988 case FFECOM_f2ccodeLONGLONG
:
5989 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5992 case FFECOM_f2ccodeCHARPTR
:
5993 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5994 ? signed_char_type_node
5995 : unsigned_char_type_node
);
5998 case FFECOM_f2ccodeFLOAT
:
5999 *type
= make_node (REAL_TYPE
);
6000 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
6001 layout_type (*type
);
6004 case FFECOM_f2ccodeDOUBLE
:
6005 *type
= make_node (REAL_TYPE
);
6006 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
6007 layout_type (*type
);
6010 case FFECOM_f2ccodeLONGDOUBLE
:
6011 *type
= make_node (REAL_TYPE
);
6012 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
6013 layout_type (*type
);
6016 case FFECOM_f2ccodeTWOREALS
:
6017 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
6020 case FFECOM_f2ccodeTWODOUBLEREALS
:
6021 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
6025 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
6026 *type
= error_mark_node
;
6030 pushdecl (build_decl (TYPE_DECL
,
6031 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
6036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6037 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6041 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6047 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6048 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
6049 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
6051 assert (code
!= -1);
6052 ffecom_f2c_typecode_
[bt
][j
] = code
;
6058 /* Finish up globals after doing all program units in file
6060 Need to handle only uninitialized COMMON areas. */
6062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6064 ffecom_finish_global_ (ffeglobal global
)
6070 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6073 if (ffeglobal_common_init (global
))
6076 cbt
= ffeglobal_hook (global
);
6077 if ((cbt
== NULL_TREE
)
6078 || !ffeglobal_common_have_size (global
))
6079 return global
; /* No need to make common, never ref'd. */
6081 suspend_momentary ();
6083 DECL_EXTERNAL (cbt
) = 0;
6085 /* Give the array a size now. */
6087 size
= build_int_2 ((ffeglobal_common_size (global
)
6088 + ffeglobal_common_pad (global
)) - 1,
6091 cbtype
= TREE_TYPE (cbt
);
6092 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6095 if (!TREE_TYPE (size
))
6096 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6097 layout_type (cbtype
);
6099 cbt
= start_decl (cbt
, FALSE
);
6100 assert (cbt
== ffeglobal_hook (global
));
6102 finish_decl (cbt
, NULL_TREE
, FALSE
);
6108 /* Finish up any untransformed symbols. */
6110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6112 ffecom_finish_symbol_transform_ (ffesymbol s
)
6114 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6117 /* It's easy to know to transform an untransformed symbol, to make sure
6118 we put out debugging info for it. But COMMON variables, unlike
6119 EQUIVALENCE ones, aren't given declarations in addition to the
6120 tree expressions that specify offsets, because COMMON variables
6121 can be referenced in the outer scope where only dummy arguments
6122 (PARM_DECLs) should really be seen. To be safe, just don't do any
6123 VAR_DECLs for COMMON variables when we transform them for real
6124 use, and therefore we do all the VAR_DECL creating here. */
6126 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6128 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
6129 || (ffesymbol_where (s
) != FFEINFO_whereNONE
6130 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
6131 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6132 /* Not transformed, and not CHARACTER*(*), and not a dummy
6133 argument, which can happen only if the entry point names
6134 it "rides in on" are all invalidated for other reasons. */
6135 s
= ffecom_sym_transform_ (s
);
6138 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6139 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6141 int yes
= suspend_momentary ();
6143 /* This isn't working, at least for dbxout. The .s file looks
6144 okay to me (burley), but in gdb 4.9 at least, the variables
6145 appear to reside somewhere outside of the common area, so
6146 it doesn't make sense to mislead anyone by generating the info
6147 on those variables until this is fixed. NOTE: Same problem
6148 with EQUIVALENCE, sadly...see similar #if later. */
6149 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6150 ffesymbol_storage (s
));
6152 resume_momentary (yes
);
6159 /* Append underscore(s) to name before calling get_identifier. "us"
6160 is nonzero if the name already contains an underscore and thus
6161 needs two underscores appended. */
6163 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6165 ffecom_get_appended_identifier_ (char us
, const char *name
)
6171 newname
= xmalloc ((i
= strlen (name
)) + 1
6172 + ffe_is_underscoring ()
6174 memcpy (newname
, name
, i
);
6176 newname
[i
+ us
] = '_';
6177 newname
[i
+ 1 + us
] = '\0';
6178 id
= get_identifier (newname
);
6186 /* Decide whether to append underscore to name before calling
6189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6191 ffecom_get_external_identifier_ (ffesymbol s
)
6194 const char *name
= ffesymbol_text (s
);
6196 /* If name is a built-in name, just return it as is. */
6198 if (!ffe_is_underscoring ()
6199 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6200 #if FFETARGET_isENFORCED_MAIN_NAME
6201 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6203 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6205 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6206 return get_identifier (name
);
6208 us
= ffe_is_second_underscore ()
6209 ? (strchr (name
, '_') != NULL
)
6212 return ffecom_get_appended_identifier_ (us
, name
);
6216 /* Decide whether to append underscore to internal name before calling
6219 This is for non-external, top-function-context names only. Transform
6220 identifier so it doesn't conflict with the transformed result
6221 of using a _different_ external name. E.g. if "CALL FOO" is
6222 transformed into "FOO_();", then the variable in "FOO_ = 3"
6223 must be transformed into something that does not conflict, since
6224 these two things should be independent.
6226 The transformation is as follows. If the name does not contain
6227 an underscore, there is no possible conflict, so just return.
6228 If the name does contain an underscore, then transform it just
6229 like we transform an external identifier. */
6231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6233 ffecom_get_identifier_ (const char *name
)
6235 /* If name does not contain an underscore, just return it as is. */
6237 if (!ffe_is_underscoring ()
6238 || (strchr (name
, '_') == NULL
))
6239 return get_identifier (name
);
6241 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6246 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6249 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6250 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6251 ffesymbol_kindtype(s));
6253 Call after setting up containing function and getting trees for all
6256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6258 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6260 ffebld expr
= ffesymbol_sfexpr (s
);
6264 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6265 static bool recurse
= FALSE
;
6267 int old_lineno
= lineno
;
6268 const char *old_input_filename
= input_filename
;
6270 ffecom_nested_entry_
= s
;
6272 /* For now, we don't have a handy pointer to where the sfunc is actually
6273 defined, though that should be easy to add to an ffesymbol. (The
6274 token/where info available might well point to the place where the type
6275 of the sfunc is declared, especially if that precedes the place where
6276 the sfunc itself is defined, which is typically the case.) We should
6277 put out a null pointer rather than point somewhere wrong, but I want to
6278 see how it works at this point. */
6280 input_filename
= ffesymbol_where_filename (s
);
6281 lineno
= ffesymbol_where_filelinenum (s
);
6283 /* Pretransform the expression so any newly discovered things belong to the
6284 outer program unit, not to the statement function. */
6286 ffecom_expr_transform_ (expr
);
6288 /* Make sure no recursive invocation of this fn (a specific case of failing
6289 to pretransform an sfunc's expression, i.e. where its expression
6290 references another untransformed sfunc) happens. */
6295 yes
= suspend_momentary ();
6297 push_f_function_context ();
6300 type
= void_type_node
;
6303 type
= ffecom_tree_type
[bt
][kt
];
6304 if (type
== NULL_TREE
)
6305 type
= integer_type_node
; /* _sym_exec_transition reports
6309 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6310 build_function_type (type
, NULL_TREE
),
6311 1, /* nested/inline */
6312 0); /* TREE_PUBLIC */
6314 /* We don't worry about COMPLEX return values here, because this is
6315 entirely internal to our code, and gcc has the ability to return COMPLEX
6316 directly as a value. */
6318 yes
= suspend_momentary ();
6321 { /* Prepend arg for where result goes. */
6324 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6326 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6328 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6330 type
= build_pointer_type (type
);
6331 result
= build_decl (PARM_DECL
, result
, type
);
6333 push_parm_decl (result
);
6336 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6338 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6340 resume_momentary (yes
);
6342 store_parm_decls (0);
6344 ffecom_start_compstmt ();
6350 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6353 result_length
= build_int_2 (sz
, 0);
6354 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6356 ffecom_prepare_let_char_ (sz
, expr
);
6358 ffecom_prepare_end ();
6360 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6361 expand_null_return ();
6365 ffecom_prepare_expr (expr
);
6367 ffecom_prepare_end ();
6369 expand_return (ffecom_modify (NULL_TREE
,
6370 DECL_RESULT (current_function_decl
),
6371 ffecom_expr (expr
)));
6377 ffecom_end_compstmt ();
6379 func
= current_function_decl
;
6380 finish_function (1);
6382 pop_f_function_context ();
6384 resume_momentary (yes
);
6388 lineno
= old_lineno
;
6389 input_filename
= old_input_filename
;
6391 ffecom_nested_entry_
= NULL
;
6398 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6400 ffecom_gfrt_args_ (ffecomGfrt ix
)
6402 return ffecom_gfrt_argstring_
[ix
];
6406 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6408 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6410 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6411 ffecom_make_gfrt_ (ix
);
6413 return ffecom_1 (ADDR_EXPR
,
6414 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6419 /* Return initialize-to-zero expression for this VAR_DECL. */
6421 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6422 /* A somewhat evil way to prevent the garbage collector
6423 from collecting 'tree' structures. */
6424 #define NUM_TRACKED_CHUNK 63
6425 static struct tree_ggc_tracker
6427 struct tree_ggc_tracker
*next
;
6428 tree trees
[NUM_TRACKED_CHUNK
];
6429 } *tracker_head
= NULL
;
6432 mark_tracker_head (void *arg
)
6434 struct tree_ggc_tracker
*head
;
6437 for (head
= * (struct tree_ggc_tracker
**) arg
;
6442 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6443 ggc_mark_tree (head
->trees
[i
]);
6448 ffecom_save_tree_forever (tree t
)
6451 if (tracker_head
!= NULL
)
6452 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6453 if (tracker_head
->trees
[i
] == NULL
)
6455 tracker_head
->trees
[i
] = t
;
6460 /* Need to allocate a new block. */
6461 struct tree_ggc_tracker
*old_head
= tracker_head
;
6463 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6464 tracker_head
->next
= old_head
;
6465 tracker_head
->trees
[0] = t
;
6466 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6467 tracker_head
->trees
[i
] = NULL
;
6472 ffecom_init_zero_ (tree decl
)
6475 int incremental
= TREE_STATIC (decl
);
6476 tree type
= TREE_TYPE (decl
);
6480 make_decl_rtl (decl
, NULL
, TREE_PUBLIC (decl
) ? 1 : 0);
6481 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6486 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6487 && (TREE_CODE (type
) != RECORD_TYPE
)
6488 && (TREE_CODE (type
) != UNION_TYPE
)
6490 init
= convert (type
, integer_zero_node
);
6491 else if (!incremental
)
6493 int momentary
= suspend_momentary ();
6495 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6496 TREE_CONSTANT (init
) = 1;
6497 TREE_STATIC (init
) = 1;
6499 resume_momentary (momentary
);
6503 int momentary
= suspend_momentary ();
6505 assemble_zeros (int_size_in_bytes (type
));
6506 init
= error_mark_node
;
6508 resume_momentary (momentary
);
6511 pop_momentary_nofree ();
6517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6519 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6525 switch (ffebld_op (arg
))
6527 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6528 if (ffetarget_length_character1
6529 (ffebld_constant_character1
6530 (ffebld_conter (arg
))) == 0)
6532 *maybe_tree
= integer_zero_node
;
6533 return convert (tree_type
, integer_zero_node
);
6536 *maybe_tree
= integer_one_node
;
6537 expr_tree
= build_int_2 (*ffetarget_text_character1
6538 (ffebld_constant_character1
6539 (ffebld_conter (arg
))),
6541 TREE_TYPE (expr_tree
) = tree_type
;
6544 case FFEBLD_opSYMTER
:
6545 case FFEBLD_opARRAYREF
:
6546 case FFEBLD_opFUNCREF
:
6547 case FFEBLD_opSUBSTR
:
6548 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6550 if ((expr_tree
== error_mark_node
)
6551 || (length_tree
== error_mark_node
))
6553 *maybe_tree
= error_mark_node
;
6554 return error_mark_node
;
6557 if (integer_zerop (length_tree
))
6559 *maybe_tree
= integer_zero_node
;
6560 return convert (tree_type
, integer_zero_node
);
6564 = ffecom_1 (INDIRECT_REF
,
6565 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6568 = ffecom_2 (ARRAY_REF
,
6569 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6572 expr_tree
= convert (tree_type
, expr_tree
);
6574 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6575 *maybe_tree
= integer_one_node
;
6576 else /* Must check length at run time. */
6578 = ffecom_truth_value
6579 (ffecom_2 (GT_EXPR
, integer_type_node
,
6581 ffecom_f2c_ftnlen_zero_node
));
6584 case FFEBLD_opPAREN
:
6585 case FFEBLD_opCONVERT
:
6586 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6588 *maybe_tree
= integer_zero_node
;
6589 return convert (tree_type
, integer_zero_node
);
6591 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6594 case FFEBLD_opCONCATENATE
:
6601 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6603 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6605 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6608 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6616 assert ("bad op in ICHAR" == NULL
);
6617 return error_mark_node
;
6622 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6626 length_arg = ffecom_intrinsic_len_ (expr);
6628 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6629 subexpressions by constructing the appropriate tree for the
6630 length-of-character-text argument in a calling sequence. */
6632 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6634 ffecom_intrinsic_len_ (ffebld expr
)
6636 ffetargetCharacter1 val
;
6639 switch (ffebld_op (expr
))
6641 case FFEBLD_opCONTER
:
6642 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6643 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6644 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6647 case FFEBLD_opSYMTER
:
6649 ffesymbol s
= ffebld_symter (expr
);
6652 item
= ffesymbol_hook (s
).decl_tree
;
6653 if (item
== NULL_TREE
)
6655 s
= ffecom_sym_transform_ (s
);
6656 item
= ffesymbol_hook (s
).decl_tree
;
6658 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6660 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6661 length
= ffesymbol_hook (s
).length_tree
;
6664 length
= build_int_2 (ffesymbol_size (s
), 0);
6665 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6668 else if (item
== error_mark_node
)
6669 length
= error_mark_node
;
6670 else /* FFEINFO_kindFUNCTION: */
6675 case FFEBLD_opARRAYREF
:
6676 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6679 case FFEBLD_opSUBSTR
:
6683 ffebld thing
= ffebld_right (expr
);
6687 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6688 start
= ffebld_head (thing
);
6689 thing
= ffebld_trail (thing
);
6690 assert (ffebld_trail (thing
) == NULL
);
6691 end
= ffebld_head (thing
);
6693 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6695 if (length
== error_mark_node
)
6704 length
= convert (ffecom_f2c_ftnlen_type_node
,
6710 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6711 ffecom_expr (start
));
6713 if (start_tree
== error_mark_node
)
6715 length
= error_mark_node
;
6721 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6722 ffecom_f2c_ftnlen_one_node
,
6723 ffecom_2 (MINUS_EXPR
,
6724 ffecom_f2c_ftnlen_type_node
,
6730 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6733 if (end_tree
== error_mark_node
)
6735 length
= error_mark_node
;
6739 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6740 ffecom_f2c_ftnlen_one_node
,
6741 ffecom_2 (MINUS_EXPR
,
6742 ffecom_f2c_ftnlen_type_node
,
6743 end_tree
, start_tree
));
6749 case FFEBLD_opCONCATENATE
:
6751 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6752 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6753 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6756 case FFEBLD_opFUNCREF
:
6757 case FFEBLD_opCONVERT
:
6758 length
= build_int_2 (ffebld_size (expr
), 0);
6759 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6763 assert ("bad op for single char arg expr" == NULL
);
6764 length
= ffecom_f2c_ftnlen_zero_node
;
6768 assert (length
!= NULL_TREE
);
6774 /* Handle CHARACTER assignments.
6776 Generates code to do the assignment. Used by ordinary assignment
6777 statement handler ffecom_let_stmt and by statement-function
6778 handler to generate code for a statement function. */
6780 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6782 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6783 ffetargetCharacterSize dest_size
, ffebld source
)
6785 ffecomConcatList_ catlist
;
6790 if ((dest_tree
== error_mark_node
)
6791 || (dest_length
== error_mark_node
))
6794 assert (dest_tree
!= NULL_TREE
);
6795 assert (dest_length
!= NULL_TREE
);
6797 /* Source might be an opCONVERT, which just means it is a different size
6798 than the destination. Since the underlying implementation here handles
6799 that (directly or via the s_copy or s_cat run-time-library functions),
6800 we don't need the "convenience" of an opCONVERT that tells us to
6801 truncate or blank-pad, particularly since the resulting implementation
6802 would probably be slower than otherwise. */
6804 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6805 source
= ffebld_left (source
);
6807 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6808 switch (ffecom_concat_list_count_ (catlist
))
6810 case 0: /* Shouldn't happen, but in case it does... */
6811 ffecom_concat_list_kill_ (catlist
);
6812 source_tree
= null_pointer_node
;
6813 source_length
= ffecom_f2c_ftnlen_zero_node
;
6814 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6815 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6816 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6817 = build_tree_list (NULL_TREE
, dest_length
);
6818 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6819 = build_tree_list (NULL_TREE
, source_length
);
6821 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6822 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6824 expand_expr_stmt (expr_tree
);
6828 case 1: /* The (fairly) easy case. */
6829 ffecom_char_args_ (&source_tree
, &source_length
,
6830 ffecom_concat_list_expr_ (catlist
, 0));
6831 ffecom_concat_list_kill_ (catlist
);
6832 assert (source_tree
!= NULL_TREE
);
6833 assert (source_length
!= NULL_TREE
);
6835 if ((source_tree
== error_mark_node
)
6836 || (source_length
== error_mark_node
))
6842 = ffecom_1 (INDIRECT_REF
,
6843 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6847 = ffecom_2 (ARRAY_REF
,
6848 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6853 = ffecom_1 (INDIRECT_REF
,
6854 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6858 = ffecom_2 (ARRAY_REF
,
6859 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6864 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6866 expand_expr_stmt (expr_tree
);
6871 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6872 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6873 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6874 = build_tree_list (NULL_TREE
, dest_length
);
6875 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6876 = build_tree_list (NULL_TREE
, source_length
);
6878 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6879 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6881 expand_expr_stmt (expr_tree
);
6885 default: /* Must actually concatenate things. */
6889 /* Heavy-duty concatenation. */
6892 int count
= ffecom_concat_list_count_ (catlist
);
6904 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
6905 FFETARGET_charactersizeNONE
, count
, TRUE
);
6906 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
6907 FFETARGET_charactersizeNONE
,
6913 hook
= ffebld_nonter_hook (source
);
6915 assert (TREE_CODE (hook
) == TREE_VEC
);
6916 assert (TREE_VEC_LENGTH (hook
) == 2);
6917 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6918 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6922 for (i
= 0; i
< count
; ++i
)
6924 ffecom_char_args_ (&citem
, &clength
,
6925 ffecom_concat_list_expr_ (catlist
, i
));
6926 if ((citem
== error_mark_node
)
6927 || (clength
== error_mark_node
))
6929 ffecom_concat_list_kill_ (catlist
);
6934 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6935 ffecom_modify (void_type_node
,
6936 ffecom_2 (ARRAY_REF
,
6937 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6939 build_int_2 (i
, 0)),
6943 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6944 ffecom_modify (void_type_node
,
6945 ffecom_2 (ARRAY_REF
,
6946 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6948 build_int_2 (i
, 0)),
6953 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6954 TREE_CHAIN (expr_tree
)
6955 = build_tree_list (NULL_TREE
,
6956 ffecom_1 (ADDR_EXPR
,
6957 build_pointer_type (TREE_TYPE (items
)),
6959 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6960 = build_tree_list (NULL_TREE
,
6961 ffecom_1 (ADDR_EXPR
,
6962 build_pointer_type (TREE_TYPE (lengths
)),
6964 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6967 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6968 convert (ffecom_f2c_ftnlen_type_node
,
6969 build_int_2 (count
, 0))));
6970 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6971 = build_tree_list (NULL_TREE
, dest_length
);
6973 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6974 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6976 expand_expr_stmt (expr_tree
);
6979 ffecom_concat_list_kill_ (catlist
);
6983 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6986 ffecom_make_gfrt_(ix);
6988 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6989 for the indicated run-time routine (ix). */
6991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6993 ffecom_make_gfrt_ (ffecomGfrt ix
)
6998 switch (ffecom_gfrt_type_
[ix
])
7000 case FFECOM_rttypeVOID_
:
7001 ttype
= void_type_node
;
7004 case FFECOM_rttypeVOIDSTAR_
:
7005 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
7008 case FFECOM_rttypeFTNINT_
:
7009 ttype
= ffecom_f2c_ftnint_type_node
;
7012 case FFECOM_rttypeINTEGER_
:
7013 ttype
= ffecom_f2c_integer_type_node
;
7016 case FFECOM_rttypeLONGINT_
:
7017 ttype
= ffecom_f2c_longint_type_node
;
7020 case FFECOM_rttypeLOGICAL_
:
7021 ttype
= ffecom_f2c_logical_type_node
;
7024 case FFECOM_rttypeREAL_F2C_
:
7025 ttype
= double_type_node
;
7028 case FFECOM_rttypeREAL_GNU_
:
7029 ttype
= float_type_node
;
7032 case FFECOM_rttypeCOMPLEX_F2C_
:
7033 ttype
= void_type_node
;
7036 case FFECOM_rttypeCOMPLEX_GNU_
:
7037 ttype
= ffecom_f2c_complex_type_node
;
7040 case FFECOM_rttypeDOUBLE_
:
7041 ttype
= double_type_node
;
7044 case FFECOM_rttypeDOUBLEREAL_
:
7045 ttype
= ffecom_f2c_doublereal_type_node
;
7048 case FFECOM_rttypeDBLCMPLX_F2C_
:
7049 ttype
= void_type_node
;
7052 case FFECOM_rttypeDBLCMPLX_GNU_
:
7053 ttype
= ffecom_f2c_doublecomplex_type_node
;
7056 case FFECOM_rttypeCHARACTER_
:
7057 ttype
= void_type_node
;
7062 assert ("bad rttype" == NULL
);
7066 ttype
= build_function_type (ttype
, NULL_TREE
);
7067 t
= build_decl (FUNCTION_DECL
,
7068 get_identifier (ffecom_gfrt_name_
[ix
]),
7070 DECL_EXTERNAL (t
) = 1;
7071 TREE_PUBLIC (t
) = 1;
7072 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
7074 t
= start_decl (t
, TRUE
);
7076 finish_decl (t
, NULL_TREE
, TRUE
);
7078 ffecom_gfrt_
[ix
] = t
;
7082 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7084 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7086 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7088 ffesymbol s
= ffestorag_symbol (st
);
7090 if (ffesymbol_namelisted (s
))
7091 ffecom_member_namelisted_
= TRUE
;
7095 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7096 the member so debugger will see it. Otherwise nobody should be
7097 referencing the member. */
7099 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7101 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7109 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7110 || (mt
== error_mark_node
))
7114 || ((s
= ffestorag_symbol (st
)) == NULL
))
7117 type
= ffecom_type_localvar_ (s
,
7118 ffesymbol_basictype (s
),
7119 ffesymbol_kindtype (s
));
7120 if (type
== error_mark_node
)
7123 t
= build_decl (VAR_DECL
,
7124 ffecom_get_identifier_ (ffesymbol_text (s
)),
7127 TREE_STATIC (t
) = TREE_STATIC (mt
);
7128 DECL_INITIAL (t
) = NULL_TREE
;
7129 TREE_ASM_WRITTEN (t
) = 1;
7132 = gen_rtx (MEM
, TYPE_MODE (type
),
7133 plus_constant (XEXP (DECL_RTL (mt
), 0),
7134 ffestorag_modulo (mst
)
7135 + ffestorag_offset (st
)
7136 - ffestorag_offset (mst
)));
7138 t
= start_decl (t
, FALSE
);
7140 finish_decl (t
, NULL_TREE
, FALSE
);
7144 /* Prepare source expression for assignment into a destination perhaps known
7145 to be of a specific size. */
7148 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
7150 ffecomConcatList_ catlist
;
7155 tree tempvar
= NULL_TREE
;
7157 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7158 source
= ffebld_left (source
);
7160 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7161 count
= ffecom_concat_list_count_ (catlist
);
7166 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
7167 FFETARGET_charactersizeNONE
, count
);
7169 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
7170 FFETARGET_charactersizeNONE
, count
);
7172 tempvar
= make_tree_vec (2);
7173 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
7174 TREE_VEC_ELT (tempvar
, 1) = itmp
;
7177 for (i
= 0; i
< count
; ++i
)
7178 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
7180 ffecom_concat_list_kill_ (catlist
);
7184 ffebld_nonter_set_hook (source
, tempvar
);
7185 current_binding_level
->prep_state
= 1;
7189 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7191 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7192 (which generates their trees) and then their trees get push_parm_decl'd.
7194 The second arg is TRUE if the dummies are for a statement function, in
7195 which case lengths are not pushed for character arguments (since they are
7196 always known by both the caller and the callee, though the code allows
7197 for someday permitting CHAR*(*) stmtfunc dummies). */
7199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7201 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7208 ffecom_transform_only_dummies_
= TRUE
;
7210 /* First push the parms corresponding to actual dummy "contents". */
7212 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7214 dummy
= ffebld_head (dumlist
);
7215 switch (ffebld_op (dummy
))
7219 continue; /* Forget alternate returns. */
7224 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7225 s
= ffebld_symter (dummy
);
7226 parm
= ffesymbol_hook (s
).decl_tree
;
7227 if (parm
== NULL_TREE
)
7229 s
= ffecom_sym_transform_ (s
);
7230 parm
= ffesymbol_hook (s
).decl_tree
;
7231 assert (parm
!= NULL_TREE
);
7233 if (parm
!= error_mark_node
)
7234 push_parm_decl (parm
);
7237 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7239 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7241 dummy
= ffebld_head (dumlist
);
7242 switch (ffebld_op (dummy
))
7246 continue; /* Forget alternate returns, they mean
7252 s
= ffebld_symter (dummy
);
7253 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7254 continue; /* Only looking for CHARACTER arguments. */
7255 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7256 continue; /* Stmtfunc arg with known size needs no
7258 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7259 continue; /* Only looking for variables and arrays. */
7260 parm
= ffesymbol_hook (s
).length_tree
;
7261 assert (parm
!= NULL_TREE
);
7262 if (parm
!= error_mark_node
)
7263 push_parm_decl (parm
);
7266 ffecom_transform_only_dummies_
= FALSE
;
7270 /* ffecom_start_progunit_ -- Beginning of program unit
7272 Does GNU back end stuff necessary to teach it about the start of its
7273 equivalent of a Fortran program unit. */
7275 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7277 ffecom_start_progunit_ ()
7279 ffesymbol fn
= ffecom_primary_entry_
;
7281 tree id
; /* Identifier (name) of function. */
7282 tree type
; /* Type of function. */
7283 tree result
; /* Result of function. */
7284 ffeinfoBasictype bt
;
7288 ffeglobalType egt
= FFEGLOBAL_type
;
7291 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7294 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7295 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7296 bool main_program
= FALSE
;
7297 int old_lineno
= lineno
;
7298 const char *old_input_filename
= input_filename
;
7301 assert (fn
!= NULL
);
7302 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7304 input_filename
= ffesymbol_where_filename (fn
);
7305 lineno
= ffesymbol_where_filelinenum (fn
);
7307 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7308 return value, but also never calls resume_momentary, when starting an
7309 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7310 same thing. It shouldn't be a problem since start_function calls
7311 temporary_allocation, but it might be necessary. If it causes a problem
7312 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7313 comment appears twice in thist file. */
7315 suspend_momentary ();
7317 switch (ffecom_primary_entry_kind_
)
7319 case FFEINFO_kindPROGRAM
:
7320 main_program
= TRUE
;
7321 gt
= FFEGLOBAL_typeMAIN
;
7322 bt
= FFEINFO_basictypeNONE
;
7323 kt
= FFEINFO_kindtypeNONE
;
7324 type
= ffecom_tree_fun_type_void
;
7329 case FFEINFO_kindBLOCKDATA
:
7330 gt
= FFEGLOBAL_typeBDATA
;
7331 bt
= FFEINFO_basictypeNONE
;
7332 kt
= FFEINFO_kindtypeNONE
;
7333 type
= ffecom_tree_fun_type_void
;
7338 case FFEINFO_kindFUNCTION
:
7339 gt
= FFEGLOBAL_typeFUNC
;
7340 egt
= FFEGLOBAL_typeEXT
;
7341 bt
= ffesymbol_basictype (fn
);
7342 kt
= ffesymbol_kindtype (fn
);
7343 if (bt
== FFEINFO_basictypeNONE
)
7345 ffeimplic_establish_symbol (fn
);
7346 if (ffesymbol_funcresult (fn
) != NULL
)
7347 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7348 bt
= ffesymbol_basictype (fn
);
7349 kt
= ffesymbol_kindtype (fn
);
7353 charfunc
= cmplxfunc
= FALSE
;
7354 else if (bt
== FFEINFO_basictypeCHARACTER
)
7355 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7356 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7357 && ffesymbol_is_f2c (fn
)
7359 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7361 charfunc
= cmplxfunc
= FALSE
;
7363 if (multi
|| charfunc
)
7364 type
= ffecom_tree_fun_type_void
;
7365 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7366 type
= ffecom_tree_fun_type
[bt
][kt
];
7368 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7370 if ((type
== NULL_TREE
)
7371 || (TREE_TYPE (type
) == NULL_TREE
))
7372 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7375 case FFEINFO_kindSUBROUTINE
:
7376 gt
= FFEGLOBAL_typeSUBR
;
7377 egt
= FFEGLOBAL_typeEXT
;
7378 bt
= FFEINFO_basictypeNONE
;
7379 kt
= FFEINFO_kindtypeNONE
;
7380 if (ffecom_is_altreturning_
)
7381 type
= ffecom_tree_subr_type
;
7383 type
= ffecom_tree_fun_type_void
;
7389 assert ("say what??" == NULL
);
7391 case FFEINFO_kindANY
:
7392 gt
= FFEGLOBAL_typeANY
;
7393 bt
= FFEINFO_basictypeNONE
;
7394 kt
= FFEINFO_kindtypeNONE
;
7395 type
= error_mark_node
;
7403 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7404 ffesymbol_text (fn
));
7406 #if FFETARGET_isENFORCED_MAIN
7407 else if (main_program
)
7408 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7411 id
= ffecom_get_external_identifier_ (fn
);
7415 0, /* nested/inline */
7416 !altentries
); /* TREE_PUBLIC */
7418 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7421 && ((g
= ffesymbol_global (fn
)) != NULL
)
7422 && ((ffeglobal_type (g
) == gt
)
7423 || (ffeglobal_type (g
) == egt
)))
7425 ffeglobal_set_hook (g
, current_function_decl
);
7428 yes
= suspend_momentary ();
7430 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7431 exec-transitioning needs current_function_decl to be filled in. So we
7432 do these things in two phases. */
7435 { /* 1st arg identifies which entrypoint. */
7436 ffecom_which_entrypoint_decl_
7437 = build_decl (PARM_DECL
,
7438 ffecom_get_invented_identifier ("__g77_%s",
7439 "which_entrypoint"),
7441 push_parm_decl (ffecom_which_entrypoint_decl_
);
7447 { /* Arg for result (return value). */
7452 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7454 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7456 type
= ffecom_multi_type_node_
;
7458 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7460 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7463 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7465 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7467 type
= build_pointer_type (type
);
7468 result
= build_decl (PARM_DECL
, result
, type
);
7470 push_parm_decl (result
);
7472 ffecom_multi_retval_
= result
;
7474 ffecom_func_result_
= result
;
7478 push_parm_decl (length
);
7479 ffecom_func_length_
= length
;
7483 if (ffecom_primary_entry_is_proc_
)
7486 arglist
= ffecom_master_arglist_
;
7488 arglist
= ffesymbol_dummyargs (fn
);
7489 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7492 resume_momentary (yes
);
7494 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7495 store_parm_decls (main_program
? 1 : 0);
7497 ffecom_start_compstmt ();
7498 /* Disallow temp vars at this level. */
7499 current_binding_level
->prep_state
= 2;
7501 lineno
= old_lineno
;
7502 input_filename
= old_input_filename
;
7504 /* This handles any symbols still untransformed, in case -g specified.
7505 This used to be done in ffecom_finish_progunit, but it turns out to
7506 be necessary to do it here so that statement functions are
7507 expanded before code. But don't bother for BLOCK DATA. */
7509 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7510 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7514 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7517 ffecom_sym_transform_(s);
7519 The ffesymbol_hook info for s is updated with appropriate backend info
7522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7524 ffecom_sym_transform_ (ffesymbol s
)
7526 tree t
; /* Transformed thingy. */
7527 tree tlen
; /* Length if CHAR*(*). */
7528 bool addr
; /* Is t the address of the thingy? */
7529 ffeinfoBasictype bt
;
7533 int old_lineno
= lineno
;
7534 const char *old_input_filename
= input_filename
;
7536 /* Must ensure special ASSIGN variables are declared at top of outermost
7537 block, else they'll end up in the innermost block when their first
7538 ASSIGN is seen, which leaves them out of scope when they're the
7539 subject of a GOTO or I/O statement.
7541 We make this variable even if -fugly-assign. Just let it go unused,
7542 in case it turns out there are cases where we really want to use this
7543 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7545 if (! ffecom_transform_only_dummies_
7546 && ffesymbol_assigned (s
)
7547 && ! ffesymbol_hook (s
).assign_tree
)
7548 s
= ffecom_sym_transform_assign_ (s
);
7550 if (ffesymbol_sfdummyparent (s
) == NULL
)
7552 input_filename
= ffesymbol_where_filename (s
);
7553 lineno
= ffesymbol_where_filelinenum (s
);
7557 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7559 input_filename
= ffesymbol_where_filename (sf
);
7560 lineno
= ffesymbol_where_filelinenum (sf
);
7563 bt
= ffeinfo_basictype (ffebld_info (s
));
7564 kt
= ffeinfo_kindtype (ffebld_info (s
));
7570 switch (ffesymbol_kind (s
))
7572 case FFEINFO_kindNONE
:
7573 switch (ffesymbol_where (s
))
7575 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7576 assert (ffecom_transform_only_dummies_
);
7578 /* Before 0.4, this could be ENTITY/DUMMY, but see
7579 ffestu_sym_end_transition -- no longer true (in particular, if
7580 it could be an ENTITY, it _will_ be made one, so that
7581 possibility won't come through here). So we never make length
7582 arg for CHARACTER type. */
7584 t
= build_decl (PARM_DECL
,
7585 ffecom_get_identifier_ (ffesymbol_text (s
)),
7586 ffecom_tree_ptr_to_subr_type
);
7588 DECL_ARTIFICIAL (t
) = 1;
7593 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7594 assert (!ffecom_transform_only_dummies_
);
7596 if (((g
= ffesymbol_global (s
)) != NULL
)
7597 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7598 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7599 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7600 && (ffeglobal_hook (g
) != NULL_TREE
)
7601 && ffe_is_globals ())
7603 t
= ffeglobal_hook (g
);
7607 t
= build_decl (FUNCTION_DECL
,
7608 ffecom_get_external_identifier_ (s
),
7609 ffecom_tree_subr_type
); /* Assume subr. */
7610 DECL_EXTERNAL (t
) = 1;
7611 TREE_PUBLIC (t
) = 1;
7613 t
= start_decl (t
, FALSE
);
7614 finish_decl (t
, NULL_TREE
, FALSE
);
7617 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7618 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7619 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7620 ffeglobal_set_hook (g
, t
);
7622 ffecom_save_tree_forever (t
);
7627 assert ("NONE where unexpected" == NULL
);
7629 case FFEINFO_whereANY
:
7634 case FFEINFO_kindENTITY
:
7635 switch (ffeinfo_where (ffesymbol_info (s
)))
7638 case FFEINFO_whereCONSTANT
:
7639 /* ~~Debugging info needed? */
7640 assert (!ffecom_transform_only_dummies_
);
7641 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7644 case FFEINFO_whereLOCAL
:
7645 assert (!ffecom_transform_only_dummies_
);
7648 ffestorag st
= ffesymbol_storage (s
);
7652 && (ffestorag_size (st
) == 0))
7654 t
= error_mark_node
;
7658 yes
= suspend_momentary ();
7659 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7660 resume_momentary (yes
);
7662 if (type
== error_mark_node
)
7664 t
= error_mark_node
;
7669 && (ffestorag_parent (st
) != NULL
))
7670 { /* Child of EQUIVALENCE parent. */
7674 ffetargetOffset offset
;
7676 est
= ffestorag_parent (st
);
7677 ffecom_transform_equiv_ (est
);
7679 et
= ffestorag_hook (est
);
7680 assert (et
!= NULL_TREE
);
7682 if (! TREE_STATIC (et
))
7683 put_var_into_stack (et
);
7685 yes
= suspend_momentary ();
7687 offset
= ffestorag_modulo (est
)
7688 + ffestorag_offset (ffesymbol_storage (s
))
7689 - ffestorag_offset (est
);
7691 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7693 /* (t_type *) (((char *) &et) + offset) */
7695 t
= convert (string_type_node
, /* (char *) */
7696 ffecom_1 (ADDR_EXPR
,
7697 build_pointer_type (TREE_TYPE (et
)),
7699 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7701 build_int_2 (offset
, 0));
7702 t
= convert (build_pointer_type (type
),
7704 TREE_CONSTANT (t
) = staticp (et
);
7708 resume_momentary (yes
);
7713 bool init
= ffesymbol_is_init (s
);
7715 yes
= suspend_momentary ();
7717 t
= build_decl (VAR_DECL
,
7718 ffecom_get_identifier_ (ffesymbol_text (s
)),
7722 || ffesymbol_namelisted (s
)
7723 #ifdef FFECOM_sizeMAXSTACKITEM
7725 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7727 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7728 && (ffecom_primary_entry_kind_
7729 != FFEINFO_kindBLOCKDATA
)
7730 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7731 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7733 TREE_STATIC (t
) = 0; /* No need to make static. */
7735 if (init
|| ffe_is_init_local_zero ())
7736 DECL_INITIAL (t
) = error_mark_node
;
7738 /* Keep -Wunused from complaining about var if it
7739 is used as sfunc arg or DATA implied-DO. */
7740 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7741 DECL_IN_SYSTEM_HEADER (t
) = 1;
7743 t
= start_decl (t
, FALSE
);
7747 if (ffesymbol_init (s
) != NULL
)
7748 initexpr
= ffecom_expr (ffesymbol_init (s
));
7750 initexpr
= ffecom_init_zero_ (t
);
7752 else if (ffe_is_init_local_zero ())
7753 initexpr
= ffecom_init_zero_ (t
);
7755 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7757 finish_decl (t
, initexpr
, FALSE
);
7759 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7761 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7762 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7763 ffestorag_size (st
)));
7766 resume_momentary (yes
);
7771 case FFEINFO_whereRESULT
:
7772 assert (!ffecom_transform_only_dummies_
);
7774 if (bt
== FFEINFO_basictypeCHARACTER
)
7775 { /* Result is already in list of dummies, use
7777 t
= ffecom_func_result_
;
7778 tlen
= ffecom_func_length_
;
7782 if ((ffecom_num_entrypoints_
== 0)
7783 && (bt
== FFEINFO_basictypeCOMPLEX
)
7784 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7785 { /* Result is already in list of dummies, use
7787 t
= ffecom_func_result_
;
7791 if (ffecom_func_result_
!= NULL_TREE
)
7793 t
= ffecom_func_result_
;
7796 if ((ffecom_num_entrypoints_
!= 0)
7797 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7799 yes
= suspend_momentary ();
7801 assert (ffecom_multi_retval_
!= NULL_TREE
);
7802 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7803 ffecom_multi_retval_
);
7804 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7805 t
, ffecom_multi_fields_
[bt
][kt
]);
7807 resume_momentary (yes
);
7811 yes
= suspend_momentary ();
7813 t
= build_decl (VAR_DECL
,
7814 ffecom_get_identifier_ (ffesymbol_text (s
)),
7815 ffecom_tree_type
[bt
][kt
]);
7816 TREE_STATIC (t
) = 0; /* Put result on stack. */
7817 t
= start_decl (t
, FALSE
);
7818 finish_decl (t
, NULL_TREE
, FALSE
);
7820 ffecom_func_result_
= t
;
7822 resume_momentary (yes
);
7825 case FFEINFO_whereDUMMY
:
7833 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7835 type
= ffecom_tree_type
[bt
][kt
];
7836 if (ffesymbol_sfdummyparent (s
) != NULL
)
7838 if (current_function_decl
== ffecom_outer_function_decl_
)
7839 { /* Exec transition before sfunc
7840 context; get it later. */
7843 t
= ffecom_get_identifier_ (ffesymbol_text
7844 (ffesymbol_sfdummyparent (s
)));
7847 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7849 assert (ffecom_transform_only_dummies_
);
7851 old_sizes
= get_pending_sizes ();
7852 put_pending_sizes (old_sizes
);
7854 if (bt
== FFEINFO_basictypeCHARACTER
)
7855 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7856 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7858 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7860 if (type
== error_mark_node
)
7863 dim
= ffebld_head (dl
);
7864 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7865 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7866 low
= ffecom_integer_one_node
;
7868 low
= ffecom_expr (ffebld_left (dim
));
7869 assert (ffebld_right (dim
) != NULL
);
7870 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7871 || ffecom_doing_entry_
)
7873 /* Used to just do high=low. But for ffecom_tree_
7874 canonize_ref_, it probably is important to correctly
7875 assess the size. E.g. given COMPLEX C(*),CFUNC and
7876 C(2)=CFUNC(C), overlap can happen, while it can't
7877 for, say, C(1)=CFUNC(C(2)). */
7878 /* Even more recently used to set to INT_MAX, but that
7879 broke when some overflow checking went into the back
7880 end. Now we just leave the upper bound unspecified. */
7884 high
= ffecom_expr (ffebld_right (dim
));
7886 /* Determine whether array is conditionally adjustable,
7887 to decide whether back-end magic is needed.
7889 Normally the front end uses the back-end function
7890 variable_size to wrap SAVE_EXPR's around expressions
7891 affecting the size/shape of an array so that the
7892 size/shape info doesn't change during execution
7893 of the compiled code even though variables and
7894 functions referenced in those expressions might.
7896 variable_size also makes sure those saved expressions
7897 get evaluated immediately upon entry to the
7898 compiled procedure -- the front end normally doesn't
7899 have to worry about that.
7901 However, there is a problem with this that affects
7902 g77's implementation of entry points, and that is
7903 that it is _not_ true that each invocation of the
7904 compiled procedure is permitted to evaluate
7905 array size/shape info -- because it is possible
7906 that, for some invocations, that info is invalid (in
7907 which case it is "promised" -- i.e. a violation of
7908 the Fortran standard -- that the compiled code
7909 won't reference the array or its size/shape
7910 during that particular invocation).
7912 To phrase this in C terms, consider this gcc function:
7914 void foo (int *n, float (*a)[*n])
7916 // a is "pointer to array ...", fyi.
7919 Suppose that, for some invocations, it is permitted
7920 for a caller of foo to do this:
7924 Now the _written_ code for foo can take such a call
7925 into account by either testing explicitly for whether
7926 (a == NULL) || (n == NULL) -- presumably it is
7927 not permitted to reference *a in various fashions
7928 if (n == NULL) I suppose -- or it can avoid it by
7929 looking at other info (other arguments, static/global
7932 However, this won't work in gcc 2.5.8 because it'll
7933 automatically emit the code to save the "*n"
7934 expression, which'll yield a NULL dereference for
7935 the "foo (NULL, NULL)" call, something the code
7936 for foo cannot prevent.
7938 g77 definitely needs to avoid executing such
7939 code anytime the pointer to the adjustable array
7940 is NULL, because even if its bounds expressions
7941 don't have any references to possible "absent"
7942 variables like "*n" -- say all variable references
7943 are to COMMON variables, i.e. global (though in C,
7944 local static could actually make sense) -- the
7945 expressions could yield other run-time problems
7946 for allowably "dead" values in those variables.
7948 For example, let's consider a more complicated
7954 void foo (float (*a)[i/j])
7959 The above is (essentially) quite valid for Fortran
7960 but, again, for a call like "foo (NULL);", it is
7961 permitted for i and j to be undefined when the
7962 call is made. If j happened to be zero, for
7963 example, emitting the code to evaluate "i/j"
7964 could result in a run-time error.
7966 Offhand, though I don't have my F77 or F90
7967 standards handy, it might even be valid for a
7968 bounds expression to contain a function reference,
7969 in which case I doubt it is permitted for an
7970 implementation to invoke that function in the
7971 Fortran case involved here (invocation of an
7972 alternate ENTRY point that doesn't have the adjustable
7973 array as one of its arguments).
7975 So, the code that the compiler would normally emit
7976 to preevaluate the size/shape info for an
7977 adjustable array _must not_ be executed at run time
7978 in certain cases. Specifically, for Fortran,
7979 the case is when the pointer to the adjustable
7980 array == NULL. (For gnu-ish C, it might be nice
7981 for the source code itself to specify an expression
7982 that, if TRUE, inhibits execution of the code. Or
7983 reverse the sense for elegance.)
7985 (Note that g77 could use a different test than NULL,
7986 actually, since it happens to always pass an
7987 integer to the called function that specifies which
7988 entry point is being invoked. Hmm, this might
7989 solve the next problem.)
7991 One way a user could, I suppose, write "foo" so
7992 it works is to insert COND_EXPR's for the
7993 size/shape info so the dangerous stuff isn't
7994 actually done, as in:
7996 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8001 The next problem is that the front end needs to
8002 be able to tell the back end about the array's
8003 decl _before_ it tells it about the conditional
8004 expression to inhibit evaluation of size/shape info,
8007 To solve this, the front end needs to be able
8008 to give the back end the expression to inhibit
8009 generation of the preevaluation code _after_
8010 it makes the decl for the adjustable array.
8012 Until then, the above example using the COND_EXPR
8013 doesn't pass muster with gcc because the "(a == NULL)"
8014 part has a reference to "a", which is still
8015 undefined at that point.
8017 g77 will therefore use a different mechanism in the
8021 && ((TREE_CODE (low
) != INTEGER_CST
)
8022 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
8025 #if 0 /* Old approach -- see below. */
8026 if (TREE_CODE (low
) != INTEGER_CST
)
8027 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
8028 ffecom_adjarray_passed_ (s
),
8030 ffecom_integer_zero_node
);
8032 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8033 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
8034 ffecom_adjarray_passed_ (s
),
8036 ffecom_integer_zero_node
);
8039 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8040 probably. Fixes 950302-1.f. */
8042 if (TREE_CODE (low
) != INTEGER_CST
)
8043 low
= variable_size (low
);
8045 /* ~~~Similarly, this fixes dumb0.f. The C front end
8046 does this, which is why dumb0.c would work. */
8048 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8049 high
= variable_size (high
);
8054 build_range_type (ffecom_integer_type_node
,
8056 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8059 if (type
== error_mark_node
)
8061 t
= error_mark_node
;
8065 if ((ffesymbol_sfdummyparent (s
) == NULL
)
8066 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
8068 type
= build_pointer_type (type
);
8072 t
= build_decl (PARM_DECL
, t
, type
);
8074 DECL_ARTIFICIAL (t
) = 1;
8077 /* If this arg is present in every entry point's list of
8078 dummy args, then we're done. */
8080 if (ffesymbol_numentries (s
)
8081 == (ffecom_num_entrypoints_
+ 1))
8086 /* If variable_size in stor-layout has been called during
8087 the above, then get_pending_sizes should have the
8088 yet-to-be-evaluated saved expressions pending.
8089 Make the whole lot of them get emitted, conditionally
8090 on whether the array decl ("t" above) is not NULL. */
8093 tree sizes
= get_pending_sizes ();
8098 tem
= TREE_CHAIN (tem
))
8100 tree temv
= TREE_VALUE (tem
);
8106 = ffecom_2 (COMPOUND_EXPR
,
8115 = ffecom_3 (COND_EXPR
,
8122 convert (TREE_TYPE (sizes
),
8123 integer_zero_node
));
8124 sizes
= ffecom_save_tree (sizes
);
8127 = tree_cons (NULL_TREE
, sizes
, tem
);
8131 put_pending_sizes (sizes
);
8137 && (ffesymbol_numentries (s
)
8138 != ffecom_num_entrypoints_
+ 1))
8140 = ffecom_2 (NE_EXPR
, integer_type_node
,
8146 && (ffesymbol_numentries (s
)
8147 != ffecom_num_entrypoints_
+ 1))
8149 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8150 ffebad_here (0, ffesymbol_where_line (s
),
8151 ffesymbol_where_column (s
));
8152 ffebad_string (ffesymbol_text (s
));
8161 case FFEINFO_whereCOMMON
:
8166 ffestorag st
= ffesymbol_storage (s
);
8170 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8171 if (st
!= NULL
) /* Else not laid out. */
8173 ffecom_transform_common_ (cs
);
8174 st
= ffesymbol_storage (s
);
8177 yes
= suspend_momentary ();
8179 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8181 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8183 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8186 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8188 if ((ct
== NULL_TREE
)
8190 || (type
== error_mark_node
))
8191 t
= error_mark_node
;
8194 ffetargetOffset offset
;
8197 cst
= ffestorag_parent (st
);
8198 assert (cst
== ffesymbol_storage (cs
));
8200 offset
= ffestorag_modulo (cst
)
8201 + ffestorag_offset (st
)
8202 - ffestorag_offset (cst
);
8204 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8206 /* (t_type *) (((char *) &ct) + offset) */
8208 t
= convert (string_type_node
, /* (char *) */
8209 ffecom_1 (ADDR_EXPR
,
8210 build_pointer_type (TREE_TYPE (ct
)),
8212 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8214 build_int_2 (offset
, 0));
8215 t
= convert (build_pointer_type (type
),
8217 TREE_CONSTANT (t
) = 1;
8222 resume_momentary (yes
);
8226 case FFEINFO_whereIMMEDIATE
:
8227 case FFEINFO_whereGLOBAL
:
8228 case FFEINFO_whereFLEETING
:
8229 case FFEINFO_whereFLEETING_CADDR
:
8230 case FFEINFO_whereFLEETING_IADDR
:
8231 case FFEINFO_whereINTRINSIC
:
8232 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8234 assert ("ENTITY where unheard of" == NULL
);
8236 case FFEINFO_whereANY
:
8237 t
= error_mark_node
;
8242 case FFEINFO_kindFUNCTION
:
8243 switch (ffeinfo_where (ffesymbol_info (s
)))
8245 case FFEINFO_whereLOCAL
: /* Me. */
8246 assert (!ffecom_transform_only_dummies_
);
8247 t
= current_function_decl
;
8250 case FFEINFO_whereGLOBAL
:
8251 assert (!ffecom_transform_only_dummies_
);
8253 if (((g
= ffesymbol_global (s
)) != NULL
)
8254 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8255 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8256 && (ffeglobal_hook (g
) != NULL_TREE
)
8257 && ffe_is_globals ())
8259 t
= ffeglobal_hook (g
);
8263 if (ffesymbol_is_f2c (s
)
8264 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8265 t
= ffecom_tree_fun_type
[bt
][kt
];
8267 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8269 t
= build_decl (FUNCTION_DECL
,
8270 ffecom_get_external_identifier_ (s
),
8272 DECL_EXTERNAL (t
) = 1;
8273 TREE_PUBLIC (t
) = 1;
8275 t
= start_decl (t
, FALSE
);
8276 finish_decl (t
, NULL_TREE
, FALSE
);
8279 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8280 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8281 ffeglobal_set_hook (g
, t
);
8283 ffecom_save_tree_forever (t
);
8287 case FFEINFO_whereDUMMY
:
8288 assert (ffecom_transform_only_dummies_
);
8290 if (ffesymbol_is_f2c (s
)
8291 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8292 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8294 t
= build_pointer_type
8295 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8297 t
= build_decl (PARM_DECL
,
8298 ffecom_get_identifier_ (ffesymbol_text (s
)),
8301 DECL_ARTIFICIAL (t
) = 1;
8306 case FFEINFO_whereCONSTANT
: /* Statement function. */
8307 assert (!ffecom_transform_only_dummies_
);
8308 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8311 case FFEINFO_whereINTRINSIC
:
8312 assert (!ffecom_transform_only_dummies_
);
8313 break; /* Let actual references generate their
8317 assert ("FUNCTION where unheard of" == NULL
);
8319 case FFEINFO_whereANY
:
8320 t
= error_mark_node
;
8325 case FFEINFO_kindSUBROUTINE
:
8326 switch (ffeinfo_where (ffesymbol_info (s
)))
8328 case FFEINFO_whereLOCAL
: /* Me. */
8329 assert (!ffecom_transform_only_dummies_
);
8330 t
= current_function_decl
;
8333 case FFEINFO_whereGLOBAL
:
8334 assert (!ffecom_transform_only_dummies_
);
8336 if (((g
= ffesymbol_global (s
)) != NULL
)
8337 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8338 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8339 && (ffeglobal_hook (g
) != NULL_TREE
)
8340 && ffe_is_globals ())
8342 t
= ffeglobal_hook (g
);
8346 t
= build_decl (FUNCTION_DECL
,
8347 ffecom_get_external_identifier_ (s
),
8348 ffecom_tree_subr_type
);
8349 DECL_EXTERNAL (t
) = 1;
8350 TREE_PUBLIC (t
) = 1;
8352 t
= start_decl (t
, FALSE
);
8353 finish_decl (t
, NULL_TREE
, FALSE
);
8356 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8357 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8358 ffeglobal_set_hook (g
, t
);
8360 ffecom_save_tree_forever (t
);
8364 case FFEINFO_whereDUMMY
:
8365 assert (ffecom_transform_only_dummies_
);
8367 t
= build_decl (PARM_DECL
,
8368 ffecom_get_identifier_ (ffesymbol_text (s
)),
8369 ffecom_tree_ptr_to_subr_type
);
8371 DECL_ARTIFICIAL (t
) = 1;
8376 case FFEINFO_whereINTRINSIC
:
8377 assert (!ffecom_transform_only_dummies_
);
8378 break; /* Let actual references generate their
8382 assert ("SUBROUTINE where unheard of" == NULL
);
8384 case FFEINFO_whereANY
:
8385 t
= error_mark_node
;
8390 case FFEINFO_kindPROGRAM
:
8391 switch (ffeinfo_where (ffesymbol_info (s
)))
8393 case FFEINFO_whereLOCAL
: /* Me. */
8394 assert (!ffecom_transform_only_dummies_
);
8395 t
= current_function_decl
;
8398 case FFEINFO_whereCOMMON
:
8399 case FFEINFO_whereDUMMY
:
8400 case FFEINFO_whereGLOBAL
:
8401 case FFEINFO_whereRESULT
:
8402 case FFEINFO_whereFLEETING
:
8403 case FFEINFO_whereFLEETING_CADDR
:
8404 case FFEINFO_whereFLEETING_IADDR
:
8405 case FFEINFO_whereIMMEDIATE
:
8406 case FFEINFO_whereINTRINSIC
:
8407 case FFEINFO_whereCONSTANT
:
8408 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8410 assert ("PROGRAM where unheard of" == NULL
);
8412 case FFEINFO_whereANY
:
8413 t
= error_mark_node
;
8418 case FFEINFO_kindBLOCKDATA
:
8419 switch (ffeinfo_where (ffesymbol_info (s
)))
8421 case FFEINFO_whereLOCAL
: /* Me. */
8422 assert (!ffecom_transform_only_dummies_
);
8423 t
= current_function_decl
;
8426 case FFEINFO_whereGLOBAL
:
8427 assert (!ffecom_transform_only_dummies_
);
8429 t
= build_decl (FUNCTION_DECL
,
8430 ffecom_get_external_identifier_ (s
),
8431 ffecom_tree_blockdata_type
);
8432 DECL_EXTERNAL (t
) = 1;
8433 TREE_PUBLIC (t
) = 1;
8435 t
= start_decl (t
, FALSE
);
8436 finish_decl (t
, NULL_TREE
, FALSE
);
8438 ffecom_save_tree_forever (t
);
8442 case FFEINFO_whereCOMMON
:
8443 case FFEINFO_whereDUMMY
:
8444 case FFEINFO_whereRESULT
:
8445 case FFEINFO_whereFLEETING
:
8446 case FFEINFO_whereFLEETING_CADDR
:
8447 case FFEINFO_whereFLEETING_IADDR
:
8448 case FFEINFO_whereIMMEDIATE
:
8449 case FFEINFO_whereINTRINSIC
:
8450 case FFEINFO_whereCONSTANT
:
8451 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8453 assert ("BLOCKDATA where unheard of" == NULL
);
8455 case FFEINFO_whereANY
:
8456 t
= error_mark_node
;
8461 case FFEINFO_kindCOMMON
:
8462 switch (ffeinfo_where (ffesymbol_info (s
)))
8464 case FFEINFO_whereLOCAL
:
8465 assert (!ffecom_transform_only_dummies_
);
8466 ffecom_transform_common_ (s
);
8469 case FFEINFO_whereNONE
:
8470 case FFEINFO_whereCOMMON
:
8471 case FFEINFO_whereDUMMY
:
8472 case FFEINFO_whereGLOBAL
:
8473 case FFEINFO_whereRESULT
:
8474 case FFEINFO_whereFLEETING
:
8475 case FFEINFO_whereFLEETING_CADDR
:
8476 case FFEINFO_whereFLEETING_IADDR
:
8477 case FFEINFO_whereIMMEDIATE
:
8478 case FFEINFO_whereINTRINSIC
:
8479 case FFEINFO_whereCONSTANT
:
8480 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8482 assert ("COMMON where unheard of" == NULL
);
8484 case FFEINFO_whereANY
:
8485 t
= error_mark_node
;
8490 case FFEINFO_kindCONSTRUCT
:
8491 switch (ffeinfo_where (ffesymbol_info (s
)))
8493 case FFEINFO_whereLOCAL
:
8494 assert (!ffecom_transform_only_dummies_
);
8497 case FFEINFO_whereNONE
:
8498 case FFEINFO_whereCOMMON
:
8499 case FFEINFO_whereDUMMY
:
8500 case FFEINFO_whereGLOBAL
:
8501 case FFEINFO_whereRESULT
:
8502 case FFEINFO_whereFLEETING
:
8503 case FFEINFO_whereFLEETING_CADDR
:
8504 case FFEINFO_whereFLEETING_IADDR
:
8505 case FFEINFO_whereIMMEDIATE
:
8506 case FFEINFO_whereINTRINSIC
:
8507 case FFEINFO_whereCONSTANT
:
8508 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8510 assert ("CONSTRUCT where unheard of" == NULL
);
8512 case FFEINFO_whereANY
:
8513 t
= error_mark_node
;
8518 case FFEINFO_kindNAMELIST
:
8519 switch (ffeinfo_where (ffesymbol_info (s
)))
8521 case FFEINFO_whereLOCAL
:
8522 assert (!ffecom_transform_only_dummies_
);
8523 t
= ffecom_transform_namelist_ (s
);
8526 case FFEINFO_whereNONE
:
8527 case FFEINFO_whereCOMMON
:
8528 case FFEINFO_whereDUMMY
:
8529 case FFEINFO_whereGLOBAL
:
8530 case FFEINFO_whereRESULT
:
8531 case FFEINFO_whereFLEETING
:
8532 case FFEINFO_whereFLEETING_CADDR
:
8533 case FFEINFO_whereFLEETING_IADDR
:
8534 case FFEINFO_whereIMMEDIATE
:
8535 case FFEINFO_whereINTRINSIC
:
8536 case FFEINFO_whereCONSTANT
:
8537 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8539 assert ("NAMELIST where unheard of" == NULL
);
8541 case FFEINFO_whereANY
:
8542 t
= error_mark_node
;
8548 assert ("kind unheard of" == NULL
);
8550 case FFEINFO_kindANY
:
8551 t
= error_mark_node
;
8555 ffesymbol_hook (s
).decl_tree
= t
;
8556 ffesymbol_hook (s
).length_tree
= tlen
;
8557 ffesymbol_hook (s
).addr
= addr
;
8559 lineno
= old_lineno
;
8560 input_filename
= old_input_filename
;
8566 /* Transform into ASSIGNable symbol.
8568 Symbol has already been transformed, but for whatever reason, the
8569 resulting decl_tree has been deemed not usable for an ASSIGN target.
8570 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8571 another local symbol of type void * and stuff that in the assign_tree
8572 argument. The F77/F90 standards allow this implementation. */
8574 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8576 ffecom_sym_transform_assign_ (ffesymbol s
)
8578 tree t
; /* Transformed thingy. */
8580 int old_lineno
= lineno
;
8581 const char *old_input_filename
= input_filename
;
8583 if (ffesymbol_sfdummyparent (s
) == NULL
)
8585 input_filename
= ffesymbol_where_filename (s
);
8586 lineno
= ffesymbol_where_filelinenum (s
);
8590 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8592 input_filename
= ffesymbol_where_filename (sf
);
8593 lineno
= ffesymbol_where_filelinenum (sf
);
8596 assert (!ffecom_transform_only_dummies_
);
8598 yes
= suspend_momentary ();
8600 t
= build_decl (VAR_DECL
,
8601 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8602 ffesymbol_text (s
)),
8603 TREE_TYPE (null_pointer_node
));
8605 switch (ffesymbol_where (s
))
8607 case FFEINFO_whereLOCAL
:
8608 /* Unlike for regular vars, SAVE status is easy to determine for
8609 ASSIGNed vars, since there's no initialization, there's no
8610 effective storage association (so "SAVE J" does not apply to
8611 K even given "EQUIVALENCE (J,K)"), there's no size issue
8612 to worry about, etc. */
8613 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8614 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8615 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8616 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8618 TREE_STATIC (t
) = 0; /* No need to make static. */
8621 case FFEINFO_whereCOMMON
:
8622 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8625 case FFEINFO_whereDUMMY
:
8626 /* Note that twinning a DUMMY means the caller won't see
8627 the ASSIGNed value. But both F77 and F90 allow implementations
8628 to do this, i.e. disallow Fortran code that would try and
8629 take advantage of actually putting a label into a variable
8630 via a dummy argument (or any other storage association, for
8632 TREE_STATIC (t
) = 0;
8636 TREE_STATIC (t
) = 0;
8640 t
= start_decl (t
, FALSE
);
8641 finish_decl (t
, NULL_TREE
, FALSE
);
8643 resume_momentary (yes
);
8645 ffesymbol_hook (s
).assign_tree
= t
;
8647 lineno
= old_lineno
;
8648 input_filename
= old_input_filename
;
8654 /* Implement COMMON area in back end.
8656 Because COMMON-based variables can be referenced in the dimension
8657 expressions of dummy (adjustable) arrays, and because dummies
8658 (in the gcc back end) need to be put in the outer binding level
8659 of a function (which has two binding levels, the outer holding
8660 the dummies and the inner holding the other vars), special care
8661 must be taken to handle COMMON areas.
8663 The current strategy is basically to always tell the back end about
8664 the COMMON area as a top-level external reference to just a block
8665 of storage of the master type of that area (e.g. integer, real,
8666 character, whatever -- not a structure). As a distinct action,
8667 if initial values are provided, tell the back end about the area
8668 as a top-level non-external (initialized) area and remember not to
8669 allow further initialization or expansion of the area. Meanwhile,
8670 if no initialization happens at all, tell the back end about
8671 the largest size we've seen declared so the space does get reserved.
8672 (This function doesn't handle all that stuff, but it does some
8673 of the important things.)
8675 Meanwhile, for COMMON variables themselves, just keep creating
8676 references like *((float *) (&common_area + offset)) each time
8677 we reference the variable. In other words, don't make a VAR_DECL
8678 or any kind of component reference (like we used to do before 0.4),
8679 though we might do that as well just for debugging purposes (and
8680 stuff the rtl with the appropriate offset expression). */
8682 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8684 ffecom_transform_common_ (ffesymbol s
)
8686 ffestorag st
= ffesymbol_storage (s
);
8687 ffeglobal g
= ffesymbol_global (s
);
8692 bool is_init
= ffestorag_is_init (st
);
8694 assert (st
!= NULL
);
8697 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8700 /* First update the size of the area in global terms. */
8702 ffeglobal_size_common (s
, ffestorag_size (st
));
8704 if (!ffeglobal_common_init (g
))
8705 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8707 cbt
= ffeglobal_hook (g
);
8709 /* If we already have declared this common block for a previous program
8710 unit, and either we already initialized it or we don't have new
8711 initialization for it, just return what we have without changing it. */
8713 if ((cbt
!= NULL_TREE
)
8715 || !DECL_EXTERNAL (cbt
)))
8717 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8721 /* Process inits. */
8725 if (ffestorag_init (st
) != NULL
)
8729 /* Set the padding for the expression, so ffecom_expr
8730 knows to insert that many zeros. */
8731 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8733 case FFEBLD_opCONTER
:
8734 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8737 case FFEBLD_opARRTER
:
8738 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8741 case FFEBLD_opACCTER
:
8742 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8746 assert ("bad op for cmn init (pad)" == NULL
);
8750 init
= ffecom_expr (sexp
);
8751 if (init
== error_mark_node
)
8752 { /* Hopefully the back end complained! */
8754 if (cbt
!= NULL_TREE
)
8759 init
= error_mark_node
;
8764 /* cbtype must be permanently allocated! */
8766 /* Allocate the MAX of the areas so far, seen filewide. */
8767 high
= build_int_2 ((ffeglobal_common_size (g
)
8768 + ffeglobal_common_pad (g
)) - 1, 0);
8769 TREE_TYPE (high
) = ffecom_integer_type_node
;
8772 cbtype
= build_array_type (char_type_node
,
8773 build_range_type (integer_type_node
,
8777 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8779 if (cbt
== NULL_TREE
)
8782 = build_decl (VAR_DECL
,
8783 ffecom_get_external_identifier_ (s
),
8785 TREE_STATIC (cbt
) = 1;
8786 TREE_PUBLIC (cbt
) = 1;
8791 TREE_TYPE (cbt
) = cbtype
;
8793 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8794 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8796 cbt
= start_decl (cbt
, TRUE
);
8797 if (ffeglobal_hook (g
) != NULL
)
8798 assert (cbt
== ffeglobal_hook (g
));
8800 assert (!init
|| !DECL_EXTERNAL (cbt
));
8802 /* Make sure that any type can live in COMMON and be referenced
8803 without getting a bus error. We could pick the most restrictive
8804 alignment of all entities actually placed in the COMMON, but
8805 this seems easy enough. */
8807 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8808 DECL_USER_ALIGN (cbt
) = 0;
8810 if (is_init
&& (ffestorag_init (st
) == NULL
))
8811 init
= ffecom_init_zero_ (cbt
);
8813 finish_decl (cbt
, init
, TRUE
);
8816 ffestorag_set_init (st
, ffebld_new_any ());
8820 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8821 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8822 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8823 (ffeglobal_common_size (g
)
8824 + ffeglobal_common_pad (g
))));
8827 ffeglobal_set_hook (g
, cbt
);
8829 ffestorag_set_hook (st
, cbt
);
8831 ffecom_save_tree_forever (cbt
);
8835 /* Make master area for local EQUIVALENCE. */
8837 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8839 ffecom_transform_equiv_ (ffestorag eqst
)
8845 bool is_init
= ffestorag_is_init (eqst
);
8848 assert (eqst
!= NULL
);
8850 eqt
= ffestorag_hook (eqst
);
8852 if (eqt
!= NULL_TREE
)
8855 /* Process inits. */
8859 if (ffestorag_init (eqst
) != NULL
)
8863 /* Set the padding for the expression, so ffecom_expr
8864 knows to insert that many zeros. */
8865 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8867 case FFEBLD_opCONTER
:
8868 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8871 case FFEBLD_opARRTER
:
8872 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8875 case FFEBLD_opACCTER
:
8876 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8880 assert ("bad op for eqv init (pad)" == NULL
);
8884 init
= ffecom_expr (sexp
);
8885 if (init
== error_mark_node
)
8886 init
= NULL_TREE
; /* Hopefully the back end complained! */
8889 init
= error_mark_node
;
8891 else if (ffe_is_init_local_zero ())
8892 init
= error_mark_node
;
8896 ffecom_member_namelisted_
= FALSE
;
8897 ffestorag_drive (ffestorag_list_equivs (eqst
),
8898 &ffecom_member_phase1_
,
8901 yes
= suspend_momentary ();
8903 high
= build_int_2 ((ffestorag_size (eqst
)
8904 + ffestorag_modulo (eqst
)) - 1, 0);
8905 TREE_TYPE (high
) = ffecom_integer_type_node
;
8907 eqtype
= build_array_type (char_type_node
,
8908 build_range_type (ffecom_integer_type_node
,
8909 ffecom_integer_zero_node
,
8912 eqt
= build_decl (VAR_DECL
,
8913 ffecom_get_invented_identifier ("__g77_equiv_%s",
8915 (ffestorag_symbol (eqst
))),
8917 DECL_EXTERNAL (eqt
) = 0;
8919 || ffecom_member_namelisted_
8920 #ifdef FFECOM_sizeMAXSTACKITEM
8921 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8923 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8924 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8925 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8926 TREE_STATIC (eqt
) = 1;
8928 TREE_STATIC (eqt
) = 0;
8929 TREE_PUBLIC (eqt
) = 0;
8930 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8931 DECL_CONTEXT (eqt
) = current_function_decl
;
8933 DECL_INITIAL (eqt
) = error_mark_node
;
8935 DECL_INITIAL (eqt
) = NULL_TREE
;
8937 eqt
= start_decl (eqt
, FALSE
);
8939 /* Make sure that any type can live in EQUIVALENCE and be referenced
8940 without getting a bus error. We could pick the most restrictive
8941 alignment of all entities actually placed in the EQUIVALENCE, but
8942 this seems easy enough. */
8944 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8945 DECL_USER_ALIGN (eqt
) = 0;
8947 if ((!is_init
&& ffe_is_init_local_zero ())
8948 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8949 init
= ffecom_init_zero_ (eqt
);
8951 finish_decl (eqt
, init
, FALSE
);
8954 ffestorag_set_init (eqst
, ffebld_new_any ());
8957 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8958 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8959 (ffestorag_size (eqst
)
8960 + ffestorag_modulo (eqst
))));
8963 ffestorag_set_hook (eqst
, eqt
);
8965 ffestorag_drive (ffestorag_list_equivs (eqst
),
8966 &ffecom_member_phase2_
,
8969 resume_momentary (yes
);
8973 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8975 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8977 ffecom_transform_namelist_ (ffesymbol s
)
8980 tree nmltype
= ffecom_type_namelist_ ();
8989 static int mynumber
= 0;
8991 yes
= suspend_momentary ();
8993 nmlt
= build_decl (VAR_DECL
,
8994 ffecom_get_invented_identifier ("__g77_namelist_%d",
8997 TREE_STATIC (nmlt
) = 1;
8998 DECL_INITIAL (nmlt
) = error_mark_node
;
9000 nmlt
= start_decl (nmlt
, FALSE
);
9002 /* Process inits. */
9004 i
= strlen (ffesymbol_text (s
));
9006 high
= build_int_2 (i
, 0);
9007 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
9009 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
9010 ffesymbol_text (s
));
9011 TREE_TYPE (nameinit
)
9012 = build_type_variant
9015 build_range_type (ffecom_f2c_ftnlen_type_node
,
9016 ffecom_f2c_ftnlen_one_node
,
9019 TREE_CONSTANT (nameinit
) = 1;
9020 TREE_STATIC (nameinit
) = 1;
9021 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
9024 varsinit
= ffecom_vardesc_array_ (s
);
9025 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
9027 TREE_CONSTANT (varsinit
) = 1;
9028 TREE_STATIC (varsinit
) = 1;
9033 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
9036 nvarsinit
= build_int_2 (i
, 0);
9037 TREE_TYPE (nvarsinit
) = integer_type_node
;
9038 TREE_CONSTANT (nvarsinit
) = 1;
9039 TREE_STATIC (nvarsinit
) = 1;
9041 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
9042 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9044 TREE_CHAIN (TREE_CHAIN (nmlinits
))
9045 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
9047 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
9048 TREE_CONSTANT (nmlinits
) = 1;
9049 TREE_STATIC (nmlinits
) = 1;
9051 finish_decl (nmlt
, nmlinits
, FALSE
);
9053 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
9055 resume_momentary (yes
);
9062 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9063 analyzed on the assumption it is calculating a pointer to be
9064 indirected through. It must return the proper decl and offset,
9065 taking into account different units of measurements for offsets. */
9067 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9069 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
9072 switch (TREE_CODE (t
))
9076 case NON_LVALUE_EXPR
:
9077 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9081 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9082 if ((*decl
== NULL_TREE
)
9083 || (*decl
== error_mark_node
))
9086 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
9088 /* An offset into COMMON. */
9089 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
9090 *offset
, TREE_OPERAND (t
, 1)));
9091 /* Convert offset (presumably in bytes) into canonical units
9092 (presumably bits). */
9093 *offset
= size_binop (MULT_EXPR
,
9094 convert (bitsizetype
, *offset
),
9095 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
9098 /* Not a COMMON reference, so an unrecognized pattern. */
9099 *decl
= error_mark_node
;
9104 *offset
= bitsize_zero_node
;
9108 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
9110 /* A reference to COMMON. */
9111 *decl
= TREE_OPERAND (t
, 0);
9112 *offset
= bitsize_zero_node
;
9117 /* Not a COMMON reference, so an unrecognized pattern. */
9118 *decl
= error_mark_node
;
9124 /* Given a tree that is possibly intended for use as an lvalue, return
9125 information representing a canonical view of that tree as a decl, an
9126 offset into that decl, and a size for the lvalue.
9128 If there's no applicable decl, NULL_TREE is returned for the decl,
9129 and the other fields are left undefined.
9131 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9132 is returned for the decl, and the other fields are left undefined.
9134 Otherwise, the decl returned currently is either a VAR_DECL or a
9137 The offset returned is always valid, but of course not necessarily
9138 a constant, and not necessarily converted into the appropriate
9139 type, leaving that up to the caller (so as to avoid that overhead
9140 if the decls being looked at are different anyway).
9142 If the size cannot be determined (e.g. an adjustable array),
9143 an ERROR_MARK node is returned for the size. Otherwise, the
9144 size returned is valid, not necessarily a constant, and not
9145 necessarily converted into the appropriate type as with the
9148 Note that the offset and size expressions are expressed in the
9149 base storage units (usually bits) rather than in the units of
9150 the type of the decl, because two decls with different types
9151 might overlap but with apparently non-overlapping array offsets,
9152 whereas converting the array offsets to consistant offsets will
9153 reveal the overlap. */
9155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9157 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9160 /* The default path is to report a nonexistant decl. */
9166 switch (TREE_CODE (t
))
9169 case IDENTIFIER_NODE
:
9178 case TRUNC_DIV_EXPR
:
9180 case FLOOR_DIV_EXPR
:
9181 case ROUND_DIV_EXPR
:
9182 case TRUNC_MOD_EXPR
:
9184 case FLOOR_MOD_EXPR
:
9185 case ROUND_MOD_EXPR
:
9187 case EXACT_DIV_EXPR
:
9188 case FIX_TRUNC_EXPR
:
9190 case FIX_FLOOR_EXPR
:
9191 case FIX_ROUND_EXPR
:
9206 case BIT_ANDTC_EXPR
:
9208 case TRUTH_ANDIF_EXPR
:
9209 case TRUTH_ORIF_EXPR
:
9210 case TRUTH_AND_EXPR
:
9212 case TRUTH_XOR_EXPR
:
9213 case TRUTH_NOT_EXPR
:
9233 *offset
= bitsize_zero_node
;
9234 *size
= TYPE_SIZE (TREE_TYPE (t
));
9239 tree array
= TREE_OPERAND (t
, 0);
9240 tree element
= TREE_OPERAND (t
, 1);
9243 if ((array
== NULL_TREE
)
9244 || (element
== NULL_TREE
))
9246 *decl
= error_mark_node
;
9250 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9252 if ((*decl
== NULL_TREE
)
9253 || (*decl
== error_mark_node
))
9256 /* Calculate ((element - base) * NBBY) + init_offset. */
9257 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
9259 TYPE_MIN_VALUE (TYPE_DOMAIN
9260 (TREE_TYPE (array
)))));
9262 *offset
= size_binop (MULT_EXPR
,
9263 convert (bitsizetype
, *offset
),
9264 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
9266 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
9268 *size
= TYPE_SIZE (TREE_TYPE (t
));
9274 /* Most of this code is to handle references to COMMON. And so
9275 far that is useful only for calling library functions, since
9276 external (user) functions might reference common areas. But
9277 even calling an external function, it's worthwhile to decode
9278 COMMON references because if not storing into COMMON, we don't
9279 want COMMON-based arguments to gratuitously force use of a
9282 *size
= TYPE_SIZE (TREE_TYPE (t
));
9284 ffecom_tree_canonize_ptr_ (decl
, offset
,
9285 TREE_OPERAND (t
, 0));
9292 case NON_LVALUE_EXPR
:
9295 case COND_EXPR
: /* More cases than we can handle. */
9297 case REFERENCE_EXPR
:
9298 case PREDECREMENT_EXPR
:
9299 case PREINCREMENT_EXPR
:
9300 case POSTDECREMENT_EXPR
:
9301 case POSTINCREMENT_EXPR
:
9304 *decl
= error_mark_node
;
9310 /* Do divide operation appropriate to type of operands. */
9312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9314 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9315 tree dest_tree
, ffebld dest
, bool *dest_used
,
9318 if ((left
== error_mark_node
)
9319 || (right
== error_mark_node
))
9320 return error_mark_node
;
9322 switch (TREE_CODE (tree_type
))
9325 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9330 if (! optimize_size
)
9331 return ffecom_2 (RDIV_EXPR
, tree_type
,
9337 if (TREE_TYPE (tree_type
)
9338 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9339 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9341 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9343 left
= ffecom_1 (ADDR_EXPR
,
9344 build_pointer_type (TREE_TYPE (left
)),
9346 left
= build_tree_list (NULL_TREE
, left
);
9347 right
= ffecom_1 (ADDR_EXPR
,
9348 build_pointer_type (TREE_TYPE (right
)),
9350 right
= build_tree_list (NULL_TREE
, right
);
9351 TREE_CHAIN (left
) = right
;
9353 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9354 ffecom_gfrt_kindtype (ix
),
9355 ffe_is_f2c_library (),
9358 dest_tree
, dest
, dest_used
,
9359 NULL_TREE
, TRUE
, hook
);
9367 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9368 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9369 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9371 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9373 left
= ffecom_1 (ADDR_EXPR
,
9374 build_pointer_type (TREE_TYPE (left
)),
9376 left
= build_tree_list (NULL_TREE
, left
);
9377 right
= ffecom_1 (ADDR_EXPR
,
9378 build_pointer_type (TREE_TYPE (right
)),
9380 right
= build_tree_list (NULL_TREE
, right
);
9381 TREE_CHAIN (left
) = right
;
9383 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9384 ffecom_gfrt_kindtype (ix
),
9385 ffe_is_f2c_library (),
9388 dest_tree
, dest
, dest_used
,
9389 NULL_TREE
, TRUE
, hook
);
9394 return ffecom_2 (RDIV_EXPR
, tree_type
,
9401 /* Build type info for non-dummy variable. */
9403 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9405 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9414 type
= ffecom_tree_type
[bt
][kt
];
9415 if (bt
== FFEINFO_basictypeCHARACTER
)
9417 hight
= build_int_2 (ffesymbol_size (s
), 0);
9418 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9423 build_range_type (ffecom_f2c_ftnlen_type_node
,
9424 ffecom_f2c_ftnlen_one_node
,
9426 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9429 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9431 if (type
== error_mark_node
)
9434 dim
= ffebld_head (dl
);
9435 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9437 if (ffebld_left (dim
) == NULL
)
9438 lowt
= integer_one_node
;
9440 lowt
= ffecom_expr (ffebld_left (dim
));
9442 if (TREE_CODE (lowt
) != INTEGER_CST
)
9443 lowt
= variable_size (lowt
);
9445 assert (ffebld_right (dim
) != NULL
);
9446 hight
= ffecom_expr (ffebld_right (dim
));
9448 if (TREE_CODE (hight
) != INTEGER_CST
)
9449 hight
= variable_size (hight
);
9451 type
= build_array_type (type
,
9452 build_range_type (ffecom_integer_type_node
,
9454 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9461 /* Build Namelist type. */
9463 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9465 ffecom_type_namelist_ ()
9467 static tree type
= NULL_TREE
;
9469 if (type
== NULL_TREE
)
9471 static tree namefield
, varsfield
, nvarsfield
;
9474 vardesctype
= ffecom_type_vardesc_ ();
9476 type
= make_node (RECORD_TYPE
);
9478 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9480 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9482 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9483 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9486 TYPE_FIELDS (type
) = namefield
;
9489 ggc_add_tree_root (&type
, 1);
9497 /* Build Vardesc type. */
9499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9501 ffecom_type_vardesc_ ()
9503 static tree type
= NULL_TREE
;
9504 static tree namefield
, addrfield
, dimsfield
, typefield
;
9506 if (type
== NULL_TREE
)
9508 type
= make_node (RECORD_TYPE
);
9510 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9512 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9514 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9515 ffecom_f2c_ptr_to_ftnlen_type_node
);
9516 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9519 TYPE_FIELDS (type
) = namefield
;
9522 ggc_add_tree_root (&type
, 1);
9530 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9532 ffecom_vardesc_ (ffebld expr
)
9536 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9537 s
= ffebld_symter (expr
);
9539 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9542 tree vardesctype
= ffecom_type_vardesc_ ();
9551 static int mynumber
= 0;
9553 yes
= suspend_momentary ();
9555 var
= build_decl (VAR_DECL
,
9556 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9559 TREE_STATIC (var
) = 1;
9560 DECL_INITIAL (var
) = error_mark_node
;
9562 var
= start_decl (var
, FALSE
);
9564 /* Process inits. */
9566 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9568 ffesymbol_text (s
));
9569 TREE_TYPE (nameinit
)
9570 = build_type_variant
9573 build_range_type (integer_type_node
,
9575 build_int_2 (i
, 0))),
9577 TREE_CONSTANT (nameinit
) = 1;
9578 TREE_STATIC (nameinit
) = 1;
9579 nameinit
= ffecom_1 (ADDR_EXPR
,
9580 build_pointer_type (TREE_TYPE (nameinit
)),
9583 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9585 dimsinit
= ffecom_vardesc_dims_ (s
);
9587 if (typeinit
== NULL_TREE
)
9589 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9590 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9591 int tc
= ffecom_f2c_typecode (bt
, kt
);
9594 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9597 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9599 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9601 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9603 TREE_CHAIN (TREE_CHAIN (varinits
))
9604 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9605 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9606 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9608 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9609 TREE_CONSTANT (varinits
) = 1;
9610 TREE_STATIC (varinits
) = 1;
9612 finish_decl (var
, varinits
, FALSE
);
9614 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9616 resume_momentary (yes
);
9618 ffesymbol_hook (s
).vardesc_tree
= var
;
9621 return ffesymbol_hook (s
).vardesc_tree
;
9625 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9627 ffecom_vardesc_array_ (ffesymbol s
)
9631 tree item
= NULL_TREE
;
9635 static int mynumber
= 0;
9637 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9639 b
= ffebld_trail (b
), ++i
)
9643 t
= ffecom_vardesc_ (ffebld_head (b
));
9645 if (list
== NULL_TREE
)
9646 list
= item
= build_tree_list (NULL_TREE
, t
);
9649 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9650 item
= TREE_CHAIN (item
);
9654 yes
= suspend_momentary ();
9656 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9657 build_range_type (integer_type_node
,
9659 build_int_2 (i
, 0)));
9660 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9661 TREE_CONSTANT (list
) = 1;
9662 TREE_STATIC (list
) = 1;
9664 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9665 var
= build_decl (VAR_DECL
, var
, item
);
9666 TREE_STATIC (var
) = 1;
9667 DECL_INITIAL (var
) = error_mark_node
;
9668 var
= start_decl (var
, FALSE
);
9669 finish_decl (var
, list
, FALSE
);
9671 resume_momentary (yes
);
9677 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9679 ffecom_vardesc_dims_ (ffesymbol s
)
9681 if (ffesymbol_dims (s
) == NULL
)
9682 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9690 tree item
= NULL_TREE
;
9695 tree baseoff
= NULL_TREE
;
9696 static int mynumber
= 0;
9698 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9699 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9701 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9702 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9705 backlist
= NULL_TREE
;
9706 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9708 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9714 if (ffebld_trail (b
) == NULL
)
9718 t
= convert (ffecom_f2c_ftnlen_type_node
,
9719 ffecom_expr (ffebld_head (e
)));
9721 if (list
== NULL_TREE
)
9722 list
= item
= build_tree_list (NULL_TREE
, t
);
9725 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9726 item
= TREE_CHAIN (item
);
9730 if (ffebld_left (ffebld_head (b
)) == NULL
)
9731 low
= ffecom_integer_one_node
;
9733 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9734 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9736 back
= build_tree_list (low
, t
);
9737 TREE_CHAIN (back
) = backlist
;
9741 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9743 if (TREE_VALUE (item
) == NULL_TREE
)
9744 baseoff
= TREE_PURPOSE (item
);
9746 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9747 TREE_PURPOSE (item
),
9748 ffecom_2 (MULT_EXPR
,
9749 ffecom_f2c_ftnlen_type_node
,
9754 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9756 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9757 TREE_CHAIN (baseoff
) = list
;
9759 numelem
= build_tree_list (NULL_TREE
, numelem
);
9760 TREE_CHAIN (numelem
) = baseoff
;
9762 numdim
= build_tree_list (NULL_TREE
, numdim
);
9763 TREE_CHAIN (numdim
) = numelem
;
9765 yes
= suspend_momentary ();
9767 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9768 build_range_type (integer_type_node
,
9771 ((int) ffesymbol_rank (s
)
9773 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9774 TREE_CONSTANT (list
) = 1;
9775 TREE_STATIC (list
) = 1;
9777 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9778 var
= build_decl (VAR_DECL
, var
, item
);
9779 TREE_STATIC (var
) = 1;
9780 DECL_INITIAL (var
) = error_mark_node
;
9781 var
= start_decl (var
, FALSE
);
9782 finish_decl (var
, list
, FALSE
);
9784 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9786 resume_momentary (yes
);
9793 /* Essentially does a "fold (build1 (code, type, node))" while checking
9794 for certain housekeeping things.
9796 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9797 ffecom_1_fn instead. */
9799 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9801 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9805 if ((node
== error_mark_node
)
9806 || (type
== error_mark_node
))
9807 return error_mark_node
;
9809 if (code
== ADDR_EXPR
)
9811 if (!mark_addressable (node
))
9812 assert ("can't mark_addressable this node!" == NULL
);
9815 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9820 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9824 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9829 if (TREE_CODE (type
) != RECORD_TYPE
)
9831 item
= build1 (code
, type
, node
);
9834 node
= ffecom_stabilize_aggregate_ (node
);
9835 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9837 ffecom_2 (COMPLEX_EXPR
, type
,
9838 ffecom_1 (NEGATE_EXPR
, realtype
,
9839 ffecom_1 (REALPART_EXPR
, realtype
,
9841 ffecom_1 (NEGATE_EXPR
, realtype
,
9842 ffecom_1 (IMAGPART_EXPR
, realtype
,
9847 item
= build1 (code
, type
, node
);
9851 if (TREE_SIDE_EFFECTS (node
))
9852 TREE_SIDE_EFFECTS (item
) = 1;
9853 if ((code
== ADDR_EXPR
) && staticp (node
))
9854 TREE_CONSTANT (item
) = 1;
9859 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9860 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9861 does not set TREE_ADDRESSABLE (because calling an inline
9862 function does not mean the function needs to be separately
9865 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9867 ffecom_1_fn (tree node
)
9872 if (node
== error_mark_node
)
9873 return error_mark_node
;
9875 type
= build_type_variant (TREE_TYPE (node
),
9876 TREE_READONLY (node
),
9877 TREE_THIS_VOLATILE (node
));
9878 item
= build1 (ADDR_EXPR
,
9879 build_pointer_type (type
), node
);
9880 if (TREE_SIDE_EFFECTS (node
))
9881 TREE_SIDE_EFFECTS (item
) = 1;
9883 TREE_CONSTANT (item
) = 1;
9888 /* Essentially does a "fold (build (code, type, node1, node2))" while
9889 checking for certain housekeeping things. */
9891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9893 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9898 if ((node1
== error_mark_node
)
9899 || (node2
== error_mark_node
)
9900 || (type
== error_mark_node
))
9901 return error_mark_node
;
9903 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9905 tree a
, b
, c
, d
, realtype
;
9908 assert ("no CONJ_EXPR support yet" == NULL
);
9909 return error_mark_node
;
9912 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9913 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9914 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9918 if (TREE_CODE (type
) != RECORD_TYPE
)
9920 item
= build (code
, type
, node1
, node2
);
9923 node1
= ffecom_stabilize_aggregate_ (node1
);
9924 node2
= ffecom_stabilize_aggregate_ (node2
);
9925 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9927 ffecom_2 (COMPLEX_EXPR
, type
,
9928 ffecom_2 (PLUS_EXPR
, realtype
,
9929 ffecom_1 (REALPART_EXPR
, realtype
,
9931 ffecom_1 (REALPART_EXPR
, realtype
,
9933 ffecom_2 (PLUS_EXPR
, realtype
,
9934 ffecom_1 (IMAGPART_EXPR
, realtype
,
9936 ffecom_1 (IMAGPART_EXPR
, realtype
,
9941 if (TREE_CODE (type
) != RECORD_TYPE
)
9943 item
= build (code
, type
, node1
, node2
);
9946 node1
= ffecom_stabilize_aggregate_ (node1
);
9947 node2
= ffecom_stabilize_aggregate_ (node2
);
9948 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9950 ffecom_2 (COMPLEX_EXPR
, type
,
9951 ffecom_2 (MINUS_EXPR
, realtype
,
9952 ffecom_1 (REALPART_EXPR
, realtype
,
9954 ffecom_1 (REALPART_EXPR
, realtype
,
9956 ffecom_2 (MINUS_EXPR
, realtype
,
9957 ffecom_1 (IMAGPART_EXPR
, realtype
,
9959 ffecom_1 (IMAGPART_EXPR
, realtype
,
9964 if (TREE_CODE (type
) != RECORD_TYPE
)
9966 item
= build (code
, type
, node1
, node2
);
9969 node1
= ffecom_stabilize_aggregate_ (node1
);
9970 node2
= ffecom_stabilize_aggregate_ (node2
);
9971 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9972 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9974 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9976 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9978 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9981 ffecom_2 (COMPLEX_EXPR
, type
,
9982 ffecom_2 (MINUS_EXPR
, realtype
,
9983 ffecom_2 (MULT_EXPR
, realtype
,
9986 ffecom_2 (MULT_EXPR
, realtype
,
9989 ffecom_2 (PLUS_EXPR
, realtype
,
9990 ffecom_2 (MULT_EXPR
, realtype
,
9993 ffecom_2 (MULT_EXPR
, realtype
,
9999 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10000 && (TREE_CODE (node2
) != RECORD_TYPE
))
10002 item
= build (code
, type
, node1
, node2
);
10005 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10006 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10007 node1
= ffecom_stabilize_aggregate_ (node1
);
10008 node2
= ffecom_stabilize_aggregate_ (node2
);
10009 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10011 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
10012 ffecom_2 (code
, type
,
10013 ffecom_1 (REALPART_EXPR
, realtype
,
10015 ffecom_1 (REALPART_EXPR
, realtype
,
10017 ffecom_2 (code
, type
,
10018 ffecom_1 (IMAGPART_EXPR
, realtype
,
10020 ffecom_1 (IMAGPART_EXPR
, realtype
,
10025 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10026 && (TREE_CODE (node2
) != RECORD_TYPE
))
10028 item
= build (code
, type
, node1
, node2
);
10031 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10032 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10033 node1
= ffecom_stabilize_aggregate_ (node1
);
10034 node2
= ffecom_stabilize_aggregate_ (node2
);
10035 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10037 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
10038 ffecom_2 (code
, type
,
10039 ffecom_1 (REALPART_EXPR
, realtype
,
10041 ffecom_1 (REALPART_EXPR
, realtype
,
10043 ffecom_2 (code
, type
,
10044 ffecom_1 (IMAGPART_EXPR
, realtype
,
10046 ffecom_1 (IMAGPART_EXPR
, realtype
,
10051 item
= build (code
, type
, node1
, node2
);
10055 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
10056 TREE_SIDE_EFFECTS (item
) = 1;
10057 return fold (item
);
10061 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10063 ffesymbol s; // the ENTRY point itself
10064 if (ffecom_2pass_advise_entrypoint(s))
10065 // the ENTRY point has been accepted
10067 Does whatever compiler needs to do when it learns about the entrypoint,
10068 like determine the return type of the master function, count the
10069 number of entrypoints, etc. Returns FALSE if the return type is
10070 not compatible with the return type(s) of other entrypoint(s).
10072 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10073 later (after _finish_progunit) be called with the same entrypoint(s)
10074 as passed to this fn for which TRUE was returned.
10077 Return FALSE if the return type conflicts with previous entrypoints. */
10079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10081 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
10083 ffebld list
; /* opITEM. */
10084 ffebld mlist
; /* opITEM. */
10085 ffebld plist
; /* opITEM. */
10086 ffebld arg
; /* ffebld_head(opITEM). */
10087 ffebld item
; /* opITEM. */
10088 ffesymbol s
; /* ffebld_symter(arg). */
10089 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
10090 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
10091 ffetargetCharacterSize size
= ffesymbol_size (entry
);
10094 if (ffecom_num_entrypoints_
== 0)
10095 { /* First entrypoint, make list of main
10096 arglist's dummies. */
10097 assert (ffecom_primary_entry_
!= NULL
);
10099 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
10100 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
10101 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
10103 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
10105 list
= ffebld_trail (list
))
10107 arg
= ffebld_head (list
);
10108 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10109 continue; /* Alternate return or some such thing. */
10110 item
= ffebld_new_item (arg
, NULL
);
10112 ffecom_master_arglist_
= item
;
10114 ffebld_set_trail (plist
, item
);
10119 /* If necessary, scan entry arglist for alternate returns. Do this scan
10120 apparently redundantly (it's done below to UNIONize the arglists) so
10121 that we don't complain about RETURN 1 if an offending ENTRY is the only
10122 one with an alternate return. */
10124 if (!ffecom_is_altreturning_
)
10126 for (list
= ffesymbol_dummyargs (entry
);
10128 list
= ffebld_trail (list
))
10130 arg
= ffebld_head (list
);
10131 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
10133 ffecom_is_altreturning_
= TRUE
;
10139 /* Now check type compatibility. */
10141 switch (ffecom_master_bt_
)
10143 case FFEINFO_basictypeNONE
:
10144 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10147 case FFEINFO_basictypeCHARACTER
:
10149 = (bt
== FFEINFO_basictypeCHARACTER
)
10150 && (kt
== ffecom_master_kt_
)
10151 && (size
== ffecom_master_size_
);
10154 case FFEINFO_basictypeANY
:
10155 return FALSE
; /* Just don't bother. */
10158 if (bt
== FFEINFO_basictypeCHARACTER
)
10164 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10166 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10167 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10174 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10175 ffest_ffebad_here_current_stmt (0);
10177 return FALSE
; /* Can't handle entrypoint. */
10180 /* Entrypoint type compatible with previous types. */
10182 ++ffecom_num_entrypoints_
;
10184 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10186 for (list
= ffesymbol_dummyargs (entry
);
10188 list
= ffebld_trail (list
))
10190 arg
= ffebld_head (list
);
10191 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10192 continue; /* Alternate return or some such thing. */
10193 s
= ffebld_symter (arg
);
10194 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10196 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10197 { /* plist points to previous item for easy
10198 appending of arg. */
10199 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10200 break; /* Already have this arg in the master list. */
10203 continue; /* Already have this arg in the master list. */
10205 /* Append this arg to the master list. */
10207 item
= ffebld_new_item (arg
, NULL
);
10209 ffecom_master_arglist_
= item
;
10211 ffebld_set_trail (plist
, item
);
10218 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10220 ffesymbol s; // the ENTRY point itself
10221 ffecom_2pass_do_entrypoint(s);
10223 Does whatever compiler needs to do to make the entrypoint actually
10224 happen. Must be called for each entrypoint after
10225 ffecom_finish_progunit is called. */
10227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10229 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10231 static int mfn_num
= 0;
10232 static int ent_num
;
10234 if (mfn_num
!= ffecom_num_fns_
)
10235 { /* First entrypoint for this program unit. */
10237 mfn_num
= ffecom_num_fns_
;
10238 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10243 --ffecom_num_entrypoints_
;
10245 ffecom_do_entry_ (entry
, ent_num
);
10250 /* Essentially does a "fold (build (code, type, node1, node2))" while
10251 checking for certain housekeeping things. Always sets
10252 TREE_SIDE_EFFECTS. */
10254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10256 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10261 if ((node1
== error_mark_node
)
10262 || (node2
== error_mark_node
)
10263 || (type
== error_mark_node
))
10264 return error_mark_node
;
10266 item
= build (code
, type
, node1
, node2
);
10267 TREE_SIDE_EFFECTS (item
) = 1;
10268 return fold (item
);
10272 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10273 checking for certain housekeeping things. */
10275 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10277 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10278 tree node2
, tree node3
)
10282 if ((node1
== error_mark_node
)
10283 || (node2
== error_mark_node
)
10284 || (node3
== error_mark_node
)
10285 || (type
== error_mark_node
))
10286 return error_mark_node
;
10288 item
= build (code
, type
, node1
, node2
, node3
);
10289 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10290 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10291 TREE_SIDE_EFFECTS (item
) = 1;
10292 return fold (item
);
10296 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10297 checking for certain housekeeping things. Always sets
10298 TREE_SIDE_EFFECTS. */
10300 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10302 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10303 tree node2
, tree node3
)
10307 if ((node1
== error_mark_node
)
10308 || (node2
== error_mark_node
)
10309 || (node3
== error_mark_node
)
10310 || (type
== error_mark_node
))
10311 return error_mark_node
;
10313 item
= build (code
, type
, node1
, node2
, node3
);
10314 TREE_SIDE_EFFECTS (item
) = 1;
10315 return fold (item
);
10320 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10322 See use by ffecom_list_expr.
10324 If expression is NULL, returns an integer zero tree. If it is not
10325 a CHARACTER expression, returns whatever ffecom_expr
10326 returns and sets the length return value to NULL_TREE. Otherwise
10327 generates code to evaluate the character expression, returns the proper
10328 pointer to the result, but does NOT set the length return value to a tree
10329 that specifies the length of the result. (In other words, the length
10330 variable is always set to NULL_TREE, because a length is never passed.)
10333 Don't set returned length, since nobody needs it (yet; someday if
10334 we allow CHARACTER*(*) dummies to statement functions, we'll need
10337 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10339 ffecom_arg_expr (ffebld expr
, tree
*length
)
10343 *length
= NULL_TREE
;
10346 return integer_zero_node
;
10348 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10349 return ffecom_expr (expr
);
10351 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10355 /* Transform expression into constant argument-pointer-to-expression tree.
10357 If the expression can be transformed into a argument-pointer-to-expression
10358 tree that is constant, that is done, and the tree returned. Else
10359 NULL_TREE is returned.
10361 That way, a caller can attempt to provide compile-time initialization
10362 of a variable and, if that fails, *then* choose to start a new block
10363 and resort to using temporaries, as appropriate. */
10366 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10369 return integer_zero_node
;
10371 if (ffebld_op (expr
) == FFEBLD_opANY
)
10374 *length
= error_mark_node
;
10375 return error_mark_node
;
10378 if (ffebld_arity (expr
) == 0
10379 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10380 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10381 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10382 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10386 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10387 assert (TREE_CONSTANT (t
));
10388 assert (! length
|| TREE_CONSTANT (*length
));
10393 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10394 *length
= build_int_2 (ffebld_size (expr
), 0);
10396 *length
= NULL_TREE
;
10400 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10402 See use by ffecom_list_ptr_to_expr.
10404 If expression is NULL, returns an integer zero tree. If it is not
10405 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10406 returns and sets the length return value to NULL_TREE. Otherwise
10407 generates code to evaluate the character expression, returns the proper
10408 pointer to the result, AND sets the length return value to a tree that
10409 specifies the length of the result.
10411 If the length argument is NULL, this is a slightly special
10412 case of building a FORMAT expression, that is, an expression that
10413 will be used at run time without regard to length. For the current
10414 implementation, which uses the libf2c library, this means it is nice
10415 to append a null byte to the end of the expression, where feasible,
10416 to make sure any diagnostic about the FORMAT string terminates at
10419 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10420 length argument. This might even be seen as a feature, if a null
10421 byte can always be appended. */
10423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10425 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10429 ffecomConcatList_ catlist
;
10431 if (length
!= NULL
)
10432 *length
= NULL_TREE
;
10435 return integer_zero_node
;
10437 switch (ffebld_op (expr
))
10439 case FFEBLD_opPERCENT_VAL
:
10440 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10441 return ffecom_expr (ffebld_left (expr
));
10446 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10447 if (temp_exp
== error_mark_node
)
10448 return error_mark_node
;
10450 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10454 case FFEBLD_opPERCENT_REF
:
10455 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10456 return ffecom_ptr_to_expr (ffebld_left (expr
));
10457 if (length
!= NULL
)
10459 ign_length
= NULL_TREE
;
10460 length
= &ign_length
;
10462 expr
= ffebld_left (expr
);
10465 case FFEBLD_opPERCENT_DESCR
:
10466 switch (ffeinfo_basictype (ffebld_info (expr
)))
10468 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10469 case FFEINFO_basictypeHOLLERITH
:
10471 case FFEINFO_basictypeCHARACTER
:
10472 break; /* Passed by descriptor anyway. */
10475 item
= ffecom_ptr_to_expr (expr
);
10476 if (item
!= error_mark_node
)
10477 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10486 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10487 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10488 && (length
!= NULL
))
10489 { /* Pass Hollerith by descriptor. */
10490 ffetargetHollerith h
;
10492 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10493 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10494 (ffebld_conter (expr
)));
10496 = build_int_2 (h
.length
, 0);
10497 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10501 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10502 return ffecom_ptr_to_expr (expr
);
10504 assert (ffeinfo_kindtype (ffebld_info (expr
))
10505 == FFEINFO_kindtypeCHARACTER1
);
10507 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10508 expr
= ffebld_left (expr
);
10510 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10511 switch (ffecom_concat_list_count_ (catlist
))
10513 case 0: /* Shouldn't happen, but in case it does... */
10514 if (length
!= NULL
)
10516 *length
= ffecom_f2c_ftnlen_zero_node
;
10517 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10519 ffecom_concat_list_kill_ (catlist
);
10520 return null_pointer_node
;
10522 case 1: /* The (fairly) easy case. */
10523 if (length
== NULL
)
10524 ffecom_char_args_with_null_ (&item
, &ign_length
,
10525 ffecom_concat_list_expr_ (catlist
, 0));
10527 ffecom_char_args_ (&item
, length
,
10528 ffecom_concat_list_expr_ (catlist
, 0));
10529 ffecom_concat_list_kill_ (catlist
);
10530 assert (item
!= NULL_TREE
);
10533 default: /* Must actually concatenate things. */
10538 int count
= ffecom_concat_list_count_ (catlist
);
10549 ffetargetCharacterSize sz
;
10551 sz
= ffecom_concat_list_maxlen_ (catlist
);
10553 assert (sz
!= FFETARGET_charactersizeNONE
);
10558 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10559 FFETARGET_charactersizeNONE
, count
, TRUE
);
10562 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10563 FFETARGET_charactersizeNONE
, count
, TRUE
);
10564 temporary
= ffecom_push_tempvar (char_type_node
,
10570 hook
= ffebld_nonter_hook (expr
);
10572 assert (TREE_CODE (hook
) == TREE_VEC
);
10573 assert (TREE_VEC_LENGTH (hook
) == 3);
10574 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10575 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10576 temporary
= TREE_VEC_ELT (hook
, 2);
10580 known_length
= ffecom_f2c_ftnlen_zero_node
;
10582 for (i
= 0; i
< count
; ++i
)
10585 && (length
== NULL
))
10586 ffecom_char_args_with_null_ (&citem
, &clength
,
10587 ffecom_concat_list_expr_ (catlist
, i
));
10589 ffecom_char_args_ (&citem
, &clength
,
10590 ffecom_concat_list_expr_ (catlist
, i
));
10591 if ((citem
== error_mark_node
)
10592 || (clength
== error_mark_node
))
10594 ffecom_concat_list_kill_ (catlist
);
10595 *length
= error_mark_node
;
10596 return error_mark_node
;
10600 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10601 ffecom_modify (void_type_node
,
10602 ffecom_2 (ARRAY_REF
,
10603 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10605 build_int_2 (i
, 0)),
10608 clength
= ffecom_save_tree (clength
);
10609 if (length
!= NULL
)
10611 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10615 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10616 ffecom_modify (void_type_node
,
10617 ffecom_2 (ARRAY_REF
,
10618 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10620 build_int_2 (i
, 0)),
10625 temporary
= ffecom_1 (ADDR_EXPR
,
10626 build_pointer_type (TREE_TYPE (temporary
)),
10629 item
= build_tree_list (NULL_TREE
, temporary
);
10631 = build_tree_list (NULL_TREE
,
10632 ffecom_1 (ADDR_EXPR
,
10633 build_pointer_type (TREE_TYPE (items
)),
10635 TREE_CHAIN (TREE_CHAIN (item
))
10636 = build_tree_list (NULL_TREE
,
10637 ffecom_1 (ADDR_EXPR
,
10638 build_pointer_type (TREE_TYPE (lengths
)),
10640 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10643 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10644 convert (ffecom_f2c_ftnlen_type_node
,
10645 build_int_2 (count
, 0))));
10646 num
= build_int_2 (sz
, 0);
10647 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10648 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10649 = build_tree_list (NULL_TREE
, num
);
10651 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10652 TREE_SIDE_EFFECTS (item
) = 1;
10653 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10657 if (length
!= NULL
)
10658 *length
= known_length
;
10661 ffecom_concat_list_kill_ (catlist
);
10662 assert (item
!= NULL_TREE
);
10667 /* Generate call to run-time function.
10669 The first arg is the GNU Fortran Run-Time function index, the second
10670 arg is the list of arguments to pass to it. Returned is the expression
10671 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10672 result (which may be void). */
10674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10676 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10678 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10679 ffecom_gfrt_kindtype (ix
),
10680 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10681 NULL_TREE
, args
, NULL_TREE
, NULL
,
10682 NULL
, NULL_TREE
, TRUE
, hook
);
10686 /* Transform constant-union to tree. */
10688 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10690 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10691 ffeinfoKindtype kt
, tree tree_type
)
10697 case FFEINFO_basictypeINTEGER
:
10703 #if FFETARGET_okINTEGER1
10704 case FFEINFO_kindtypeINTEGER1
:
10705 val
= ffebld_cu_val_integer1 (*cu
);
10709 #if FFETARGET_okINTEGER2
10710 case FFEINFO_kindtypeINTEGER2
:
10711 val
= ffebld_cu_val_integer2 (*cu
);
10715 #if FFETARGET_okINTEGER3
10716 case FFEINFO_kindtypeINTEGER3
:
10717 val
= ffebld_cu_val_integer3 (*cu
);
10721 #if FFETARGET_okINTEGER4
10722 case FFEINFO_kindtypeINTEGER4
:
10723 val
= ffebld_cu_val_integer4 (*cu
);
10728 assert ("bad INTEGER constant kind type" == NULL
);
10729 /* Fall through. */
10730 case FFEINFO_kindtypeANY
:
10731 return error_mark_node
;
10733 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10734 TREE_TYPE (item
) = tree_type
;
10738 case FFEINFO_basictypeLOGICAL
:
10744 #if FFETARGET_okLOGICAL1
10745 case FFEINFO_kindtypeLOGICAL1
:
10746 val
= ffebld_cu_val_logical1 (*cu
);
10750 #if FFETARGET_okLOGICAL2
10751 case FFEINFO_kindtypeLOGICAL2
:
10752 val
= ffebld_cu_val_logical2 (*cu
);
10756 #if FFETARGET_okLOGICAL3
10757 case FFEINFO_kindtypeLOGICAL3
:
10758 val
= ffebld_cu_val_logical3 (*cu
);
10762 #if FFETARGET_okLOGICAL4
10763 case FFEINFO_kindtypeLOGICAL4
:
10764 val
= ffebld_cu_val_logical4 (*cu
);
10769 assert ("bad LOGICAL constant kind type" == NULL
);
10770 /* Fall through. */
10771 case FFEINFO_kindtypeANY
:
10772 return error_mark_node
;
10774 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10775 TREE_TYPE (item
) = tree_type
;
10779 case FFEINFO_basictypeREAL
:
10781 REAL_VALUE_TYPE val
;
10785 #if FFETARGET_okREAL1
10786 case FFEINFO_kindtypeREAL1
:
10787 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10791 #if FFETARGET_okREAL2
10792 case FFEINFO_kindtypeREAL2
:
10793 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10797 #if FFETARGET_okREAL3
10798 case FFEINFO_kindtypeREAL3
:
10799 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10803 #if FFETARGET_okREAL4
10804 case FFEINFO_kindtypeREAL4
:
10805 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10810 assert ("bad REAL constant kind type" == NULL
);
10811 /* Fall through. */
10812 case FFEINFO_kindtypeANY
:
10813 return error_mark_node
;
10815 item
= build_real (tree_type
, val
);
10819 case FFEINFO_basictypeCOMPLEX
:
10821 REAL_VALUE_TYPE real
;
10822 REAL_VALUE_TYPE imag
;
10823 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10827 #if FFETARGET_okCOMPLEX1
10828 case FFEINFO_kindtypeREAL1
:
10829 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10830 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10834 #if FFETARGET_okCOMPLEX2
10835 case FFEINFO_kindtypeREAL2
:
10836 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10837 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10841 #if FFETARGET_okCOMPLEX3
10842 case FFEINFO_kindtypeREAL3
:
10843 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10844 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10848 #if FFETARGET_okCOMPLEX4
10849 case FFEINFO_kindtypeREAL4
:
10850 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10851 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10856 assert ("bad REAL constant kind type" == NULL
);
10857 /* Fall through. */
10858 case FFEINFO_kindtypeANY
:
10859 return error_mark_node
;
10861 item
= ffecom_build_complex_constant_ (tree_type
,
10862 build_real (el_type
, real
),
10863 build_real (el_type
, imag
));
10867 case FFEINFO_basictypeCHARACTER
:
10868 { /* Happens only in DATA and similar contexts. */
10869 ffetargetCharacter1 val
;
10873 #if FFETARGET_okCHARACTER1
10874 case FFEINFO_kindtypeLOGICAL1
:
10875 val
= ffebld_cu_val_character1 (*cu
);
10880 assert ("bad CHARACTER constant kind type" == NULL
);
10881 /* Fall through. */
10882 case FFEINFO_kindtypeANY
:
10883 return error_mark_node
;
10885 item
= build_string (ffetarget_length_character1 (val
),
10886 ffetarget_text_character1 (val
));
10888 = build_type_variant (build_array_type (char_type_node
,
10890 (integer_type_node
,
10893 (ffetarget_length_character1
10899 case FFEINFO_basictypeHOLLERITH
:
10901 ffetargetHollerith h
;
10903 h
= ffebld_cu_val_hollerith (*cu
);
10905 /* If not at least as wide as default INTEGER, widen it. */
10906 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10907 item
= build_string (h
.length
, h
.text
);
10910 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10912 memcpy (str
, h
.text
, h
.length
);
10913 memset (&str
[h
.length
], ' ',
10914 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10916 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10920 = build_type_variant (build_array_type (char_type_node
,
10922 (integer_type_node
,
10930 case FFEINFO_basictypeTYPELESS
:
10932 ffetargetInteger1 ival
;
10933 ffetargetTypeless tless
;
10936 tless
= ffebld_cu_val_typeless (*cu
);
10937 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10938 assert (error
== FFEBAD
);
10940 item
= build_int_2 ((int) ival
, 0);
10945 assert ("not yet on constant type" == NULL
);
10946 /* Fall through. */
10947 case FFEINFO_basictypeANY
:
10948 return error_mark_node
;
10951 TREE_CONSTANT (item
) = 1;
10958 /* Transform expression into constant tree.
10960 If the expression can be transformed into a tree that is constant,
10961 that is done, and the tree returned. Else NULL_TREE is returned.
10963 That way, a caller can attempt to provide compile-time initialization
10964 of a variable and, if that fails, *then* choose to start a new block
10965 and resort to using temporaries, as appropriate. */
10968 ffecom_const_expr (ffebld expr
)
10971 return integer_zero_node
;
10973 if (ffebld_op (expr
) == FFEBLD_opANY
)
10974 return error_mark_node
;
10976 if (ffebld_arity (expr
) == 0
10977 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10979 /* ~~Enable once common/equivalence is handled properly? */
10980 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10982 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10983 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10987 t
= ffecom_expr (expr
);
10988 assert (TREE_CONSTANT (t
));
10995 /* Handy way to make a field in a struct/union. */
10997 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10999 ffecom_decl_field (tree context
, tree prevfield
,
11000 const char *name
, tree type
)
11004 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
11005 DECL_CONTEXT (field
) = context
;
11006 DECL_ALIGN (field
) = 0;
11007 DECL_USER_ALIGN (field
) = 0;
11008 if (prevfield
!= NULL_TREE
)
11009 TREE_CHAIN (prevfield
) = field
;
11017 ffecom_close_include (FILE *f
)
11019 #if FFECOM_GCC_INCLUDE
11020 ffecom_close_include_ (f
);
11025 ffecom_decode_include_option (char *spec
)
11027 #if FFECOM_GCC_INCLUDE
11028 return ffecom_decode_include_option_ (spec
);
11034 /* End a compound statement (block). */
11036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11038 ffecom_end_compstmt (void)
11040 return bison_rule_compstmt_ ();
11042 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11044 /* ffecom_end_transition -- Perform end transition on all symbols
11046 ffecom_end_transition();
11048 Calls ffecom_sym_end_transition for each global and local symbol. */
11051 ffecom_end_transition ()
11053 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11057 if (ffe_is_ffedebug ())
11058 fprintf (dmpout
, "; end_stmt_transition\n");
11060 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11061 ffecom_list_blockdata_
= NULL
;
11062 ffecom_list_common_
= NULL
;
11065 ffesymbol_drive (ffecom_sym_end_transition
);
11066 if (ffe_is_ffedebug ())
11068 ffestorag_report ();
11069 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11070 ffesymbol_report_all ();
11074 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11075 ffecom_start_progunit_ ();
11077 for (item
= ffecom_list_blockdata_
;
11079 item
= ffebld_trail (item
))
11087 static int number
= 0;
11089 callee
= ffebld_head (item
);
11090 s
= ffebld_symter (callee
);
11091 t
= ffesymbol_hook (s
).decl_tree
;
11092 if (t
== NULL_TREE
)
11094 s
= ffecom_sym_transform_ (s
);
11095 t
= ffesymbol_hook (s
).decl_tree
;
11098 yes
= suspend_momentary ();
11100 dt
= build_pointer_type (TREE_TYPE (t
));
11102 var
= build_decl (VAR_DECL
,
11103 ffecom_get_invented_identifier ("__g77_forceload_%d",
11106 DECL_EXTERNAL (var
) = 0;
11107 TREE_STATIC (var
) = 1;
11108 TREE_PUBLIC (var
) = 0;
11109 DECL_INITIAL (var
) = error_mark_node
;
11110 TREE_USED (var
) = 1;
11112 var
= start_decl (var
, FALSE
);
11114 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
11116 finish_decl (var
, t
, FALSE
);
11118 resume_momentary (yes
);
11121 /* This handles any COMMON areas that weren't referenced but have, for
11122 example, important initial data. */
11124 for (item
= ffecom_list_common_
;
11126 item
= ffebld_trail (item
))
11127 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
11129 ffecom_list_common_
= NULL
;
11133 /* ffecom_exec_transition -- Perform exec transition on all symbols
11135 ffecom_exec_transition();
11137 Calls ffecom_sym_exec_transition for each global and local symbol.
11138 Make sure error updating not inhibited. */
11141 ffecom_exec_transition ()
11145 if (ffe_is_ffedebug ())
11146 fprintf (dmpout
, "; exec_stmt_transition\n");
11148 inhibited
= ffebad_inhibit ();
11149 ffebad_set_inhibit (FALSE
);
11151 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11152 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11153 if (ffe_is_ffedebug ())
11155 ffestorag_report ();
11156 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11157 ffesymbol_report_all ();
11162 ffebad_set_inhibit (TRUE
);
11165 /* Handle assignment statement.
11167 Convert dest and source using ffecom_expr, then join them
11168 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11172 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11179 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11184 /* This attempts to replicate the test below, but must not be
11185 true when the test below is false. (Always err on the side
11186 of creating unused temporaries, to avoid ICEs.) */
11187 if (ffebld_op (dest
) != FFEBLD_opSYMTER
11188 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
11189 && (TREE_CODE (dest_tree
) != VAR_DECL
11190 || TREE_ADDRESSABLE (dest_tree
))))
11192 ffecom_prepare_expr_ (source
, dest
);
11197 ffecom_prepare_expr_ (source
, NULL
);
11201 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11203 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11204 create a temporary through which the assignment is to take place,
11205 since MODIFY_EXPR doesn't handle partial overlap properly. */
11206 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
11207 && ffecom_possible_partial_overlap_ (dest
, source
))
11209 assign_temp
= ffecom_make_tempvar ("complex_let",
11211 [ffebld_basictype (dest
)]
11212 [ffebld_kindtype (dest
)],
11213 FFETARGET_charactersizeNONE
,
11217 assign_temp
= NULL_TREE
;
11219 ffecom_prepare_end ();
11221 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
11222 if (dest_tree
== error_mark_node
)
11225 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11226 || TREE_ADDRESSABLE (dest_tree
))
11227 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
11231 assert (! dest_used
);
11233 source_tree
= ffecom_expr (source
);
11235 if (source_tree
== error_mark_node
)
11239 expr_tree
= source_tree
;
11240 else if (assign_temp
)
11243 /* The back end understands a conceptual move (evaluate source;
11244 store into dest), so use that, in case it can determine
11245 that it is going to use, say, two registers as temporaries
11246 anyway. So don't use the temp (and someday avoid generating
11247 it, once this code starts triggering regularly). */
11248 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
11252 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11255 expand_expr_stmt (expr_tree
);
11256 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11262 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11266 expand_expr_stmt (expr_tree
);
11270 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
11271 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11273 ffecom_prepare_end ();
11275 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11276 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11281 /* ffecom_expr -- Transform expr into gcc tree
11284 ffebld expr; // FFE expression.
11285 tree = ffecom_expr(expr);
11287 Recursive descent on expr while making corresponding tree nodes and
11288 attaching type info and such. */
11290 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11292 ffecom_expr (ffebld expr
)
11294 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
11298 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11300 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11302 ffecom_expr_assign (ffebld expr
)
11304 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11308 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11310 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11312 ffecom_expr_assign_w (ffebld expr
)
11314 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11318 /* Transform expr for use as into read/write tree and stabilize the
11319 reference. Not for use on CHARACTER expressions.
11321 Recursive descent on expr while making corresponding tree nodes and
11322 attaching type info and such. */
11324 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11326 ffecom_expr_rw (tree type
, ffebld expr
)
11328 assert (expr
!= NULL
);
11329 /* Different target types not yet supported. */
11330 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11332 return stabilize_reference (ffecom_expr (expr
));
11336 /* Transform expr for use as into write tree and stabilize the
11337 reference. Not for use on CHARACTER expressions.
11339 Recursive descent on expr while making corresponding tree nodes and
11340 attaching type info and such. */
11342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11344 ffecom_expr_w (tree type
, ffebld expr
)
11346 assert (expr
!= NULL
);
11347 /* Different target types not yet supported. */
11348 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11350 return stabilize_reference (ffecom_expr (expr
));
11354 /* Do global stuff. */
11356 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11358 ffecom_finish_compile ()
11360 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11361 assert (current_function_decl
== NULL_TREE
);
11363 ffeglobal_drive (ffecom_finish_global_
);
11367 /* Public entry point for front end to access finish_decl. */
11369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11371 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11373 assert (!is_top_level
);
11374 finish_decl (decl
, init
, FALSE
);
11378 /* Finish a program unit. */
11380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11382 ffecom_finish_progunit ()
11384 ffecom_end_compstmt ();
11386 ffecom_previous_function_decl_
= current_function_decl
;
11387 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11389 finish_function (0);
11394 /* Wrapper for get_identifier. pattern is sprintf-like. */
11396 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11398 ffecom_get_invented_identifier (const char *pattern
, ...)
11404 va_start (ap
, pattern
);
11405 if (vasprintf (&nam
, pattern
, ap
) == 0)
11408 decl
= get_identifier (nam
);
11410 IDENTIFIER_INVENTED (decl
) = 1;
11415 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11417 assert (gfrt
< FFECOM_gfrt
);
11419 switch (ffecom_gfrt_type_
[gfrt
])
11421 case FFECOM_rttypeVOID_
:
11422 case FFECOM_rttypeVOIDSTAR_
:
11423 return FFEINFO_basictypeNONE
;
11425 case FFECOM_rttypeFTNINT_
:
11426 return FFEINFO_basictypeINTEGER
;
11428 case FFECOM_rttypeINTEGER_
:
11429 return FFEINFO_basictypeINTEGER
;
11431 case FFECOM_rttypeLONGINT_
:
11432 return FFEINFO_basictypeINTEGER
;
11434 case FFECOM_rttypeLOGICAL_
:
11435 return FFEINFO_basictypeLOGICAL
;
11437 case FFECOM_rttypeREAL_F2C_
:
11438 case FFECOM_rttypeREAL_GNU_
:
11439 return FFEINFO_basictypeREAL
;
11441 case FFECOM_rttypeCOMPLEX_F2C_
:
11442 case FFECOM_rttypeCOMPLEX_GNU_
:
11443 return FFEINFO_basictypeCOMPLEX
;
11445 case FFECOM_rttypeDOUBLE_
:
11446 case FFECOM_rttypeDOUBLEREAL_
:
11447 return FFEINFO_basictypeREAL
;
11449 case FFECOM_rttypeDBLCMPLX_F2C_
:
11450 case FFECOM_rttypeDBLCMPLX_GNU_
:
11451 return FFEINFO_basictypeCOMPLEX
;
11453 case FFECOM_rttypeCHARACTER_
:
11454 return FFEINFO_basictypeCHARACTER
;
11457 return FFEINFO_basictypeANY
;
11462 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11464 assert (gfrt
< FFECOM_gfrt
);
11466 switch (ffecom_gfrt_type_
[gfrt
])
11468 case FFECOM_rttypeVOID_
:
11469 case FFECOM_rttypeVOIDSTAR_
:
11470 return FFEINFO_kindtypeNONE
;
11472 case FFECOM_rttypeFTNINT_
:
11473 return FFEINFO_kindtypeINTEGER1
;
11475 case FFECOM_rttypeINTEGER_
:
11476 return FFEINFO_kindtypeINTEGER1
;
11478 case FFECOM_rttypeLONGINT_
:
11479 return FFEINFO_kindtypeINTEGER4
;
11481 case FFECOM_rttypeLOGICAL_
:
11482 return FFEINFO_kindtypeLOGICAL1
;
11484 case FFECOM_rttypeREAL_F2C_
:
11485 case FFECOM_rttypeREAL_GNU_
:
11486 return FFEINFO_kindtypeREAL1
;
11488 case FFECOM_rttypeCOMPLEX_F2C_
:
11489 case FFECOM_rttypeCOMPLEX_GNU_
:
11490 return FFEINFO_kindtypeREAL1
;
11492 case FFECOM_rttypeDOUBLE_
:
11493 case FFECOM_rttypeDOUBLEREAL_
:
11494 return FFEINFO_kindtypeREAL2
;
11496 case FFECOM_rttypeDBLCMPLX_F2C_
:
11497 case FFECOM_rttypeDBLCMPLX_GNU_
:
11498 return FFEINFO_kindtypeREAL2
;
11500 case FFECOM_rttypeCHARACTER_
:
11501 return FFEINFO_kindtypeCHARACTER1
;
11504 return FFEINFO_kindtypeANY
;
11518 tree double_ftype_double
;
11519 tree float_ftype_float
;
11520 tree ldouble_ftype_ldouble
;
11521 tree ffecom_tree_ptr_to_fun_type_void
;
11523 /* This block of code comes from the now-obsolete cktyps.c. It checks
11524 whether the compiler environment is buggy in known ways, some of which
11525 would, if not explicitly checked here, result in subtle bugs in g77. */
11527 if (ffe_is_do_internal_checks ())
11529 static char names
[][12]
11531 {"bar", "bletch", "foo", "foobar"};
11536 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11537 (int (*)(const void *, const void *)) strcmp
);
11538 if (name
!= (char *) &names
[2])
11540 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11545 ul
= strtoul ("123456789", NULL
, 10);
11546 if (ul
!= 123456789L)
11548 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11549 in proj.h" == NULL
);
11553 fl
= atof ("56.789");
11554 if ((fl
< 56.788) || (fl
> 56.79))
11556 assert ("atof not type double, fix your #include <stdio.h>"
11562 #if FFECOM_GCC_INCLUDE
11563 ffecom_initialize_char_syntax_ ();
11566 ffecom_outer_function_decl_
= NULL_TREE
;
11567 current_function_decl
= NULL_TREE
;
11568 named_labels
= NULL_TREE
;
11569 current_binding_level
= NULL_BINDING_LEVEL
;
11570 free_binding_level
= NULL_BINDING_LEVEL
;
11571 /* Make the binding_level structure for global names. */
11573 global_binding_level
= current_binding_level
;
11574 current_binding_level
->prep_state
= 2;
11576 build_common_tree_nodes (1);
11578 /* Define `int' and `char' first so that dbx will output them first. */
11579 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11580 integer_type_node
));
11581 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11583 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11584 long_integer_type_node
));
11585 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11586 unsigned_type_node
));
11587 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11588 long_unsigned_type_node
));
11589 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11590 long_long_integer_type_node
));
11591 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11592 long_long_unsigned_type_node
));
11593 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11594 short_integer_type_node
));
11595 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11596 short_unsigned_type_node
));
11598 /* Set the sizetype before we make other types. This *should* be the
11599 first type we create. */
11602 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11603 ffecom_typesize_pointer_
11604 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11606 build_common_tree_nodes_2 (0);
11608 /* Define both `signed char' and `unsigned char'. */
11609 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11610 signed_char_type_node
));
11612 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11613 unsigned_char_type_node
));
11615 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11617 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11618 double_type_node
));
11619 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11620 long_double_type_node
));
11622 /* For now, override what build_common_tree_nodes has done. */
11623 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11624 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11625 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11626 complex_long_double_type_node
11627 = ffecom_make_complex_type_ (long_double_type_node
);
11629 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11630 complex_integer_type_node
));
11631 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11632 complex_float_type_node
));
11633 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11634 complex_double_type_node
));
11635 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11636 complex_long_double_type_node
));
11638 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11640 /* We are not going to have real types in C with less than byte alignment,
11641 so we might as well not have any types that claim to have it. */
11642 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11643 TYPE_USER_ALIGN (void_type_node
) = 0;
11645 string_type_node
= build_pointer_type (char_type_node
);
11647 ffecom_tree_fun_type_void
11648 = build_function_type (void_type_node
, NULL_TREE
);
11650 ffecom_tree_ptr_to_fun_type_void
11651 = build_pointer_type (ffecom_tree_fun_type_void
);
11653 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11656 = build_function_type (float_type_node
,
11657 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11659 double_ftype_double
11660 = build_function_type (double_type_node
,
11661 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11663 ldouble_ftype_ldouble
11664 = build_function_type (long_double_type_node
,
11665 tree_cons (NULL_TREE
, long_double_type_node
,
11668 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11669 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11671 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11672 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11673 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11674 ffecom_f2c_typecode_
[i
][j
] = -1;
11677 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11678 to size FLOAT_TYPE_SIZE because they have to be the same size as
11679 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11680 Compiler options and other such stuff that change the ways these
11681 types are set should not affect this particular setup. */
11683 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11684 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11685 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11687 type
= ffetype_new ();
11689 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11691 ffetype_set_ams (type
,
11692 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11693 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11694 ffetype_set_star (base_type
,
11695 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11697 ffetype_set_kind (base_type
, 1, type
);
11698 ffecom_typesize_integer1_
= ffetype_size (type
);
11699 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11701 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11702 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11703 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11706 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11707 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11708 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11710 type
= ffetype_new ();
11711 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11713 ffetype_set_ams (type
,
11714 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11715 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11716 ffetype_set_star (base_type
,
11717 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11719 ffetype_set_kind (base_type
, 3, type
);
11720 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11722 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11723 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11724 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11727 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11728 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11729 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11731 type
= ffetype_new ();
11732 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11734 ffetype_set_ams (type
,
11735 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11736 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11737 ffetype_set_star (base_type
,
11738 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11740 ffetype_set_kind (base_type
, 6, type
);
11741 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11743 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11744 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11745 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11748 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11749 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11750 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11752 type
= ffetype_new ();
11753 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11755 ffetype_set_ams (type
,
11756 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11757 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11758 ffetype_set_star (base_type
,
11759 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11761 ffetype_set_kind (base_type
, 2, type
);
11762 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11764 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11765 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11766 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11770 if (ffe_is_do_internal_checks ()
11771 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11772 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11773 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11774 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11776 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11781 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11782 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11783 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11785 type
= ffetype_new ();
11787 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11789 ffetype_set_ams (type
,
11790 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11791 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11792 ffetype_set_star (base_type
,
11793 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11795 ffetype_set_kind (base_type
, 1, type
);
11796 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11798 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11799 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11800 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11802 type
= ffetype_new ();
11803 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11805 ffetype_set_ams (type
,
11806 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11807 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11808 ffetype_set_star (base_type
,
11809 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11811 ffetype_set_kind (base_type
, 3, type
);
11812 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11814 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11815 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11816 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11818 type
= ffetype_new ();
11819 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11821 ffetype_set_ams (type
,
11822 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11823 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11824 ffetype_set_star (base_type
,
11825 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11827 ffetype_set_kind (base_type
, 6, type
);
11828 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11830 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11831 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11832 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11834 type
= ffetype_new ();
11835 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11837 ffetype_set_ams (type
,
11838 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11839 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11840 ffetype_set_star (base_type
,
11841 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11843 ffetype_set_kind (base_type
, 2, type
);
11844 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11846 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11847 = t
= make_node (REAL_TYPE
);
11848 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11849 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11852 type
= ffetype_new ();
11854 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11856 ffetype_set_ams (type
,
11857 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11858 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11859 ffetype_set_star (base_type
,
11860 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11862 ffetype_set_kind (base_type
, 1, type
);
11863 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11864 = FFETARGET_f2cTYREAL
;
11865 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11867 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11868 = t
= make_node (REAL_TYPE
);
11869 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11870 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11873 type
= ffetype_new ();
11874 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11876 ffetype_set_ams (type
,
11877 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11878 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11879 ffetype_set_star (base_type
,
11880 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11882 ffetype_set_kind (base_type
, 2, type
);
11883 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11884 = FFETARGET_f2cTYDREAL
;
11885 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11887 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11888 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11889 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11891 type
= ffetype_new ();
11893 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11895 ffetype_set_ams (type
,
11896 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11897 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11898 ffetype_set_star (base_type
,
11899 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11901 ffetype_set_kind (base_type
, 1, type
);
11902 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11903 = FFETARGET_f2cTYCOMPLEX
;
11904 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11906 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11907 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11908 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11910 type
= ffetype_new ();
11911 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11913 ffetype_set_ams (type
,
11914 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11915 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11916 ffetype_set_star (base_type
,
11917 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11919 ffetype_set_kind (base_type
, 2,
11921 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11922 = FFETARGET_f2cTYDCOMPLEX
;
11923 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11925 /* Make function and ptr-to-function types for non-CHARACTER types. */
11927 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11928 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11930 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11932 if (i
== FFEINFO_basictypeINTEGER
)
11934 /* Figure out the smallest INTEGER type that can hold
11935 a pointer on this machine. */
11936 if (GET_MODE_SIZE (TYPE_MODE (t
))
11937 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11939 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11940 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11941 > GET_MODE_SIZE (TYPE_MODE (t
))))
11942 ffecom_pointer_kind_
= j
;
11945 else if (i
== FFEINFO_basictypeCOMPLEX
)
11946 t
= void_type_node
;
11947 /* For f2c compatibility, REAL functions are really
11948 implemented as DOUBLE PRECISION. */
11949 else if ((i
== FFEINFO_basictypeREAL
)
11950 && (j
== FFEINFO_kindtypeREAL1
))
11951 t
= ffecom_tree_type
11952 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11954 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11956 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11960 /* Set up pointer types. */
11962 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11963 fatal ("no INTEGER type can hold a pointer on this configuration");
11964 else if (0 && ffe_is_do_internal_checks ())
11965 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11966 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11967 FFEINFO_kindtypeINTEGERDEFAULT
),
11969 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11970 ffecom_pointer_kind_
));
11972 if (ffe_is_ugly_assign ())
11973 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11975 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11976 if (0 && ffe_is_do_internal_checks ())
11977 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11979 ffecom_integer_type_node
11980 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11981 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11982 integer_zero_node
);
11983 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11986 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11987 Turns out that by TYLONG, runtime/libI77/lio.h really means
11988 "whatever size an ftnint is". For consistency and sanity,
11989 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11990 all are INTEGER, which we also make out of whatever back-end
11991 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11992 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11993 accommodate machines like the Alpha. Note that this suggests
11994 f2c and libf2c are missing a distinction perhaps needed on
11995 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11997 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11998 FFETARGET_f2cTYLONG
);
11999 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
12000 FFETARGET_f2cTYSHORT
);
12001 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
12002 FFETARGET_f2cTYINT1
);
12003 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
12004 FFETARGET_f2cTYQUAD
);
12005 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
12006 FFETARGET_f2cTYLOGICAL
);
12007 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
12008 FFETARGET_f2cTYLOGICAL2
);
12009 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
12010 FFETARGET_f2cTYLOGICAL1
);
12011 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
12012 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
12013 FFETARGET_f2cTYQUAD
);
12015 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12016 loop. CHARACTER items are built as arrays of unsigned char. */
12018 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
12019 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
12020 type
= ffetype_new ();
12022 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
12023 FFEINFO_kindtypeCHARACTER1
,
12025 ffetype_set_ams (type
,
12026 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12027 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12028 ffetype_set_kind (base_type
, 1, type
);
12029 assert (ffetype_size (type
)
12030 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
12032 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
12033 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
12034 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
12035 [FFEINFO_kindtypeCHARACTER1
]
12036 = ffecom_tree_ptr_to_fun_type_void
;
12037 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
12038 = FFETARGET_f2cTYCHAR
;
12040 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
12043 /* Make multi-return-value type and fields. */
12045 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
12049 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12050 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12054 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
12055 continue; /* Not supported. */
12056 sprintf (&name
[0], "bt_%s_kt_%s",
12057 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
12058 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
12059 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
12060 get_identifier (name
),
12061 ffecom_tree_type
[i
][j
]);
12062 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
12063 = ffecom_multi_type_node_
;
12064 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
12065 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
12066 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
12067 field
= ffecom_multi_fields_
[i
][j
];
12070 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
12071 layout_type (ffecom_multi_type_node_
);
12073 /* Subroutines usually return integer because they might have alternate
12076 ffecom_tree_subr_type
12077 = build_function_type (integer_type_node
, NULL_TREE
);
12078 ffecom_tree_ptr_to_subr_type
12079 = build_pointer_type (ffecom_tree_subr_type
);
12080 ffecom_tree_blockdata_type
12081 = build_function_type (void_type_node
, NULL_TREE
);
12083 builtin_function ("__builtin_sqrtf", float_ftype_float
,
12084 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtf");
12085 builtin_function ("__builtin_fsqrt", double_ftype_double
,
12086 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrt");
12087 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
12088 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtl");
12089 builtin_function ("__builtin_sinf", float_ftype_float
,
12090 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinf");
12091 builtin_function ("__builtin_sin", double_ftype_double
,
12092 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin");
12093 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
12094 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinl");
12095 builtin_function ("__builtin_cosf", float_ftype_float
,
12096 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosf");
12097 builtin_function ("__builtin_cos", double_ftype_double
,
12098 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos");
12099 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
12100 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosl");
12103 pedantic_lvalues
= FALSE
;
12106 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
12109 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
12112 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
12115 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
12116 FFECOM_f2cDOUBLEREAL
,
12118 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
12121 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
12122 FFECOM_f2cDOUBLECOMPLEX
,
12124 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
12127 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
12130 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
12133 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
12136 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12140 ffecom_f2c_ftnlen_zero_node
12141 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12143 ffecom_f2c_ftnlen_one_node
12144 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12146 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12147 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12149 ffecom_f2c_ptr_to_ftnlen_type_node
12150 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12152 ffecom_f2c_ptr_to_ftnint_type_node
12153 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12155 ffecom_f2c_ptr_to_integer_type_node
12156 = build_pointer_type (ffecom_f2c_integer_type_node
);
12158 ffecom_f2c_ptr_to_real_type_node
12159 = build_pointer_type (ffecom_f2c_real_type_node
);
12161 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12162 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12164 REAL_VALUE_TYPE point_5
;
12166 #ifdef REAL_ARITHMETIC
12167 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12171 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12172 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12175 /* Do "extern int xargc;". */
12177 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12178 get_identifier ("f__xargc"),
12179 integer_type_node
);
12180 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12181 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12182 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12183 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12184 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12186 #if 0 /* This is being fixed, and seems to be working now. */
12187 if ((FLOAT_TYPE_SIZE
!= 32)
12188 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12190 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12191 (int) FLOAT_TYPE_SIZE
);
12192 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12193 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12194 warning ("properly unless they all are 32 bits wide.");
12195 warning ("Please keep this in mind before you report bugs. g77 should");
12196 warning ("support non-32-bit machines better as of version 0.6.");
12200 #if 0 /* Code in ste.c that would crash has been commented out. */
12201 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12202 < TYPE_PRECISION (string_type_node
))
12203 /* I/O will probably crash. */
12204 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12205 TYPE_PRECISION (string_type_node
),
12206 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12209 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12210 if (TYPE_PRECISION (ffecom_integer_type_node
)
12211 < TYPE_PRECISION (string_type_node
))
12212 /* ASSIGN 10 TO I will crash. */
12213 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12214 ASSIGN statement might fail",
12215 TYPE_PRECISION (string_type_node
),
12216 TYPE_PRECISION (ffecom_integer_type_node
));
12221 /* ffecom_init_2 -- Initialize
12223 ffecom_init_2(); */
12225 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12229 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12230 assert (current_function_decl
== NULL_TREE
);
12231 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12233 ffecom_master_arglist_
= NULL
;
12235 ffecom_primary_entry_
= NULL
;
12236 ffecom_is_altreturning_
= FALSE
;
12237 ffecom_func_result_
= NULL_TREE
;
12238 ffecom_multi_retval_
= NULL_TREE
;
12242 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12245 ffebld expr; // FFE opITEM list.
12246 tree = ffecom_list_expr(expr);
12248 List of actual args is transformed into corresponding gcc backend list. */
12250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12252 ffecom_list_expr (ffebld expr
)
12255 tree
*plist
= &list
;
12256 tree trail
= NULL_TREE
; /* Append char length args here. */
12257 tree
*ptrail
= &trail
;
12260 while (expr
!= NULL
)
12262 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
12264 if (texpr
== error_mark_node
)
12265 return error_mark_node
;
12267 *plist
= build_tree_list (NULL_TREE
, texpr
);
12268 plist
= &TREE_CHAIN (*plist
);
12269 expr
= ffebld_trail (expr
);
12270 if (length
!= NULL_TREE
)
12272 *ptrail
= build_tree_list (NULL_TREE
, length
);
12273 ptrail
= &TREE_CHAIN (*ptrail
);
12283 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12286 ffebld expr; // FFE opITEM list.
12287 tree = ffecom_list_ptr_to_expr(expr);
12289 List of actual args is transformed into corresponding gcc backend list for
12290 use in calling an external procedure (vs. a statement function). */
12292 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12294 ffecom_list_ptr_to_expr (ffebld expr
)
12297 tree
*plist
= &list
;
12298 tree trail
= NULL_TREE
; /* Append char length args here. */
12299 tree
*ptrail
= &trail
;
12302 while (expr
!= NULL
)
12304 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
12306 if (texpr
== error_mark_node
)
12307 return error_mark_node
;
12309 *plist
= build_tree_list (NULL_TREE
, texpr
);
12310 plist
= &TREE_CHAIN (*plist
);
12311 expr
= ffebld_trail (expr
);
12312 if (length
!= NULL_TREE
)
12314 *ptrail
= build_tree_list (NULL_TREE
, length
);
12315 ptrail
= &TREE_CHAIN (*ptrail
);
12325 /* Obtain gcc's LABEL_DECL tree for label. */
12327 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12329 ffecom_lookup_label (ffelab label
)
12333 if (ffelab_hook (label
) == NULL_TREE
)
12335 char labelname
[16];
12337 switch (ffelab_type (label
))
12339 case FFELAB_typeLOOPEND
:
12340 case FFELAB_typeNOTLOOP
:
12341 case FFELAB_typeENDIF
:
12342 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12343 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12345 DECL_CONTEXT (glabel
) = current_function_decl
;
12346 DECL_MODE (glabel
) = VOIDmode
;
12349 case FFELAB_typeFORMAT
:
12350 glabel
= build_decl (VAR_DECL
,
12351 ffecom_get_invented_identifier
12352 ("__g77_format_%d", (int) ffelab_value (label
)),
12353 build_type_variant (build_array_type
12357 TREE_CONSTANT (glabel
) = 1;
12358 TREE_STATIC (glabel
) = 1;
12359 DECL_CONTEXT (glabel
) = 0;
12360 DECL_INITIAL (glabel
) = NULL
;
12361 make_decl_rtl (glabel
, NULL
, 0);
12362 expand_decl (glabel
);
12364 ffecom_save_tree_forever (glabel
);
12368 case FFELAB_typeANY
:
12369 glabel
= error_mark_node
;
12373 assert ("bad label type" == NULL
);
12377 ffelab_set_hook (label
, glabel
);
12381 glabel
= ffelab_hook (label
);
12388 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12389 a single source specification (as in the fourth argument of MVBITS).
12390 If the type is NULL_TREE, the type of lhs is used to make the type of
12391 the MODIFY_EXPR. */
12393 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12395 ffecom_modify (tree newtype
, tree lhs
,
12398 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12399 return error_mark_node
;
12401 if (newtype
== NULL_TREE
)
12402 newtype
= TREE_TYPE (lhs
);
12404 if (TREE_SIDE_EFFECTS (lhs
))
12405 lhs
= stabilize_reference (lhs
);
12407 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12412 /* Register source file name. */
12415 ffecom_file (const char *name
)
12417 #if FFECOM_GCC_INCLUDE
12418 ffecom_file_ (name
);
12422 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12425 ffecom_notify_init_storage(st);
12427 Gets called when all possible units in an aggregate storage area (a LOCAL
12428 with equivalences or a COMMON) have been initialized. The initialization
12429 info either is in ffestorag_init or, if that is NULL,
12430 ffestorag_accretion:
12432 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12433 even for an array if the array is one element in length!
12435 ffestorag_accretion will contain an opACCTER. It is much like an
12436 opARRTER except it has an ffebit object in it instead of just a size.
12437 The back end can use the info in the ffebit object, if it wants, to
12438 reduce the amount of actual initialization, but in any case it should
12439 kill the ffebit object when done. Also, set accretion to NULL but
12440 init to a non-NULL value.
12442 After performing initialization, DO NOT set init to NULL, because that'll
12443 tell the front end it is ok for more initialization to happen. Instead,
12444 set init to an opANY expression or some such thing that you can use to
12445 tell that you've already initialized the object.
12448 Support two-pass FFE. */
12451 ffecom_notify_init_storage (ffestorag st
)
12453 ffebld init
; /* The initialization expression. */
12454 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12455 ffetargetOffset size
; /* The size of the entity. */
12456 ffetargetAlign pad
; /* Its initial padding. */
12459 if (ffestorag_init (st
) == NULL
)
12461 init
= ffestorag_accretion (st
);
12462 assert (init
!= NULL
);
12463 ffestorag_set_accretion (st
, NULL
);
12464 ffestorag_set_accretes (st
, 0);
12466 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12467 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12468 size
= ffebld_accter_size (init
);
12469 pad
= ffebld_accter_pad (init
);
12470 ffebit_kill (ffebld_accter_bits (init
));
12471 ffebld_set_op (init
, FFEBLD_opARRTER
);
12472 ffebld_set_arrter (init
, ffebld_accter (init
));
12473 ffebld_arrter_set_size (init
, size
);
12474 ffebld_arrter_set_pad (init
, size
);
12478 ffestorag_set_init (st
, init
);
12483 init
= ffestorag_init (st
);
12486 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12487 ffestorag_set_init (st
, ffebld_new_any ());
12489 if (ffebld_op (init
) == FFEBLD_opANY
)
12490 return; /* Oh, we already did this! */
12492 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12496 if (ffestorag_symbol (st
) != NULL
)
12497 s
= ffestorag_symbol (st
);
12499 s
= ffestorag_typesymbol (st
);
12501 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12502 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12503 ffebld_dump (init
);
12504 fputc ('\n', dmpout
);
12508 #endif /* if FFECOM_ONEPASS */
12511 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12514 ffecom_notify_init_symbol(s);
12516 Gets called when all possible units in a symbol (not placed in COMMON
12517 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12518 have been initialized. The initialization info either is in
12519 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12521 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12522 even for an array if the array is one element in length!
12524 ffesymbol_accretion will contain an opACCTER. It is much like an
12525 opARRTER except it has an ffebit object in it instead of just a size.
12526 The back end can use the info in the ffebit object, if it wants, to
12527 reduce the amount of actual initialization, but in any case it should
12528 kill the ffebit object when done. Also, set accretion to NULL but
12529 init to a non-NULL value.
12531 After performing initialization, DO NOT set init to NULL, because that'll
12532 tell the front end it is ok for more initialization to happen. Instead,
12533 set init to an opANY expression or some such thing that you can use to
12534 tell that you've already initialized the object.
12537 Support two-pass FFE. */
12540 ffecom_notify_init_symbol (ffesymbol s
)
12542 ffebld init
; /* The initialization expression. */
12543 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12544 ffetargetOffset size
; /* The size of the entity. */
12545 ffetargetAlign pad
; /* Its initial padding. */
12548 if (ffesymbol_storage (s
) == NULL
)
12549 return; /* Do nothing until COMMON/EQUIVALENCE
12550 possibilities checked. */
12552 if ((ffesymbol_init (s
) == NULL
)
12553 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12555 ffesymbol_set_accretion (s
, NULL
);
12556 ffesymbol_set_accretes (s
, 0);
12558 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12559 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12560 size
= ffebld_accter_size (init
);
12561 pad
= ffebld_accter_pad (init
);
12562 ffebit_kill (ffebld_accter_bits (init
));
12563 ffebld_set_op (init
, FFEBLD_opARRTER
);
12564 ffebld_set_arrter (init
, ffebld_accter (init
));
12565 ffebld_arrter_set_size (init
, size
);
12566 ffebld_arrter_set_pad (init
, size
);
12570 ffesymbol_set_init (s
, init
);
12575 init
= ffesymbol_init (s
);
12579 ffesymbol_set_init (s
, ffebld_new_any ());
12581 if (ffebld_op (init
) == FFEBLD_opANY
)
12582 return; /* Oh, we already did this! */
12584 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12585 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12586 ffebld_dump (init
);
12587 fputc ('\n', dmpout
);
12590 #endif /* if FFECOM_ONEPASS */
12593 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12596 ffecom_notify_primary_entry(s);
12598 Gets called when implicit or explicit PROGRAM statement seen or when
12599 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12600 global symbol that serves as the entry point. */
12603 ffecom_notify_primary_entry (ffesymbol s
)
12605 ffecom_primary_entry_
= s
;
12606 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12608 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12609 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12610 ffecom_primary_entry_is_proc_
= TRUE
;
12612 ffecom_primary_entry_is_proc_
= FALSE
;
12614 if (!ffe_is_silent ())
12616 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12617 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12619 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12622 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12623 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12628 for (list
= ffesymbol_dummyargs (s
);
12630 list
= ffebld_trail (list
))
12632 arg
= ffebld_head (list
);
12633 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12635 ffecom_is_altreturning_
= TRUE
;
12644 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12646 #if FFECOM_GCC_INCLUDE
12647 return ffecom_open_include_ (name
, l
, c
);
12649 return fopen (name
, "r");
12653 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12656 ffebld expr; // FFE expression.
12657 tree = ffecom_ptr_to_expr(expr);
12659 Like ffecom_expr, but sticks address-of in front of most things. */
12661 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12663 ffecom_ptr_to_expr (ffebld expr
)
12666 ffeinfoBasictype bt
;
12667 ffeinfoKindtype kt
;
12670 assert (expr
!= NULL
);
12672 switch (ffebld_op (expr
))
12674 case FFEBLD_opSYMTER
:
12675 s
= ffebld_symter (expr
);
12676 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12680 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12681 assert (ix
!= FFECOM_gfrt
);
12682 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12684 ffecom_make_gfrt_ (ix
);
12685 item
= ffecom_gfrt_
[ix
];
12690 item
= ffesymbol_hook (s
).decl_tree
;
12691 if (item
== NULL_TREE
)
12693 s
= ffecom_sym_transform_ (s
);
12694 item
= ffesymbol_hook (s
).decl_tree
;
12697 assert (item
!= NULL
);
12698 if (item
== error_mark_node
)
12700 if (!ffesymbol_hook (s
).addr
)
12701 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12705 case FFEBLD_opARRAYREF
:
12706 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12708 case FFEBLD_opCONTER
:
12710 bt
= ffeinfo_basictype (ffebld_info (expr
));
12711 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12713 item
= ffecom_constantunion (&ffebld_constant_union
12714 (ffebld_conter (expr
)), bt
, kt
,
12715 ffecom_tree_type
[bt
][kt
]);
12716 if (item
== error_mark_node
)
12717 return error_mark_node
;
12718 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12723 return error_mark_node
;
12726 bt
= ffeinfo_basictype (ffebld_info (expr
));
12727 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12729 item
= ffecom_expr (expr
);
12730 if (item
== error_mark_node
)
12731 return error_mark_node
;
12733 /* The back end currently optimizes a bit too zealously for us, in that
12734 we fail JCB001 if the following block of code is omitted. It checks
12735 to see if the transformed expression is a symbol or array reference,
12736 and encloses it in a SAVE_EXPR if that is the case. */
12739 if ((TREE_CODE (item
) == VAR_DECL
)
12740 || (TREE_CODE (item
) == PARM_DECL
)
12741 || (TREE_CODE (item
) == RESULT_DECL
)
12742 || (TREE_CODE (item
) == INDIRECT_REF
)
12743 || (TREE_CODE (item
) == ARRAY_REF
)
12744 || (TREE_CODE (item
) == COMPONENT_REF
)
12746 || (TREE_CODE (item
) == OFFSET_REF
)
12748 || (TREE_CODE (item
) == BUFFER_REF
)
12749 || (TREE_CODE (item
) == REALPART_EXPR
)
12750 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12752 item
= ffecom_save_tree (item
);
12755 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12760 assert ("fall-through error" == NULL
);
12761 return error_mark_node
;
12765 /* Obtain a temp var with given data type.
12767 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12768 or >= 0 for a CHARACTER type.
12770 elements is -1 for a scalar or > 0 for an array of type. */
12772 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12774 ffecom_make_tempvar (const char *commentary
, tree type
,
12775 ffetargetCharacterSize size
, int elements
)
12779 static int mynumber
;
12781 assert (current_binding_level
->prep_state
< 2);
12783 if (type
== error_mark_node
)
12784 return error_mark_node
;
12786 yes
= suspend_momentary ();
12788 if (size
!= FFETARGET_charactersizeNONE
)
12789 type
= build_array_type (type
,
12790 build_range_type (ffecom_f2c_ftnlen_type_node
,
12791 ffecom_f2c_ftnlen_one_node
,
12792 build_int_2 (size
, 0)));
12793 if (elements
!= -1)
12794 type
= build_array_type (type
,
12795 build_range_type (integer_type_node
,
12797 build_int_2 (elements
- 1,
12799 t
= build_decl (VAR_DECL
,
12800 ffecom_get_invented_identifier ("__g77_%s_%d",
12805 t
= start_decl (t
, FALSE
);
12806 finish_decl (t
, NULL_TREE
, FALSE
);
12808 resume_momentary (yes
);
12814 /* Prepare argument pointer to expression.
12816 Like ffecom_prepare_expr, except for expressions to be evaluated
12817 via ffecom_arg_ptr_to_expr. */
12820 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12822 /* ~~For now, it seems to be the same thing. */
12823 ffecom_prepare_expr (expr
);
12827 /* End of preparations. */
12830 ffecom_prepare_end (void)
12832 int prep_state
= current_binding_level
->prep_state
;
12834 assert (prep_state
< 2);
12835 current_binding_level
->prep_state
= 2;
12837 return (prep_state
== 1) ? TRUE
: FALSE
;
12840 /* Prepare expression.
12842 This is called before any code is generated for the current block.
12843 It scans the expression, declares any temporaries that might be needed
12844 during evaluation of the expression, and stores those temporaries in
12845 the appropriate "hook" fields of the expression. `dest', if not NULL,
12846 specifies the destination that ffecom_expr_ will see, in case that
12847 helps avoid generating unused temporaries.
12849 ~~Improve to avoid allocating unused temporaries by taking `dest'
12850 into account vis-a-vis aliasing requirements of complex/character
12854 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12856 ffeinfoBasictype bt
;
12857 ffeinfoKindtype kt
;
12858 ffetargetCharacterSize sz
;
12859 tree tempvar
= NULL_TREE
;
12861 assert (current_binding_level
->prep_state
< 2);
12866 bt
= ffeinfo_basictype (ffebld_info (expr
));
12867 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12868 sz
= ffeinfo_size (ffebld_info (expr
));
12870 /* Generate whatever temporaries are needed to represent the result
12871 of the expression. */
12873 if (bt
== FFEINFO_basictypeCHARACTER
)
12875 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12876 expr
= ffebld_left (expr
);
12879 switch (ffebld_op (expr
))
12882 /* Don't make temps for SYMTER, CONTER, etc. */
12883 if (ffebld_arity (expr
) == 0)
12888 case FFEINFO_basictypeCOMPLEX
:
12889 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12893 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12896 s
= ffebld_symter (ffebld_left (expr
));
12897 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12898 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12899 && ! ffesymbol_is_f2c (s
))
12900 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12901 && ! ffe_is_f2c_library ()))
12904 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12906 /* Requires special treatment. There's no POW_CC function
12907 in libg2c, so POW_ZZ is used, which means we always
12908 need a double-complex temp, not a single-complex. */
12909 kt
= FFEINFO_kindtypeREAL2
;
12911 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12912 /* The other ops don't need temps for complex operands. */
12915 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12916 REAL(C). See 19990325-0.f, routine `check', for cases. */
12917 tempvar
= ffecom_make_tempvar ("complex",
12919 [FFEINFO_basictypeCOMPLEX
][kt
],
12920 FFETARGET_charactersizeNONE
,
12924 case FFEINFO_basictypeCHARACTER
:
12925 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12928 if (sz
== FFETARGET_charactersizeNONE
)
12929 /* ~~Kludge alert! This should someday be fixed. */
12932 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12941 case FFEBLD_opPOWER
:
12944 tree rtmp
, ltmp
, result
;
12946 ltype
= ffecom_type_expr (ffebld_left (expr
));
12947 rtype
= ffecom_type_expr (ffebld_right (expr
));
12949 rtmp
= ffecom_make_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1);
12950 ltmp
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12951 result
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12953 tempvar
= make_tree_vec (3);
12954 TREE_VEC_ELT (tempvar
, 0) = rtmp
;
12955 TREE_VEC_ELT (tempvar
, 1) = ltmp
;
12956 TREE_VEC_ELT (tempvar
, 2) = result
;
12961 case FFEBLD_opCONCATENATE
:
12963 /* This gets special handling, because only one set of temps
12964 is needed for a tree of these -- the tree is treated as
12965 a flattened list of concatenations when generating code. */
12967 ffecomConcatList_ catlist
;
12968 tree ltmp
, itmp
, result
;
12972 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12973 count
= ffecom_concat_list_count_ (catlist
);
12978 = ffecom_make_tempvar ("concat_len",
12979 ffecom_f2c_ftnlen_type_node
,
12980 FFETARGET_charactersizeNONE
, count
);
12982 = ffecom_make_tempvar ("concat_item",
12983 ffecom_f2c_address_type_node
,
12984 FFETARGET_charactersizeNONE
, count
);
12986 = ffecom_make_tempvar ("concat_res",
12988 ffecom_concat_list_maxlen_ (catlist
),
12991 tempvar
= make_tree_vec (3);
12992 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12993 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12994 TREE_VEC_ELT (tempvar
, 2) = result
;
12997 for (i
= 0; i
< count
; ++i
)
12998 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
13001 ffecom_concat_list_kill_ (catlist
);
13005 ffebld_nonter_set_hook (expr
, tempvar
);
13006 current_binding_level
->prep_state
= 1;
13011 case FFEBLD_opCONVERT
:
13012 if (bt
== FFEINFO_basictypeCHARACTER
13013 && ((ffebld_size_known (ffebld_left (expr
))
13014 == FFETARGET_charactersizeNONE
)
13015 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
13016 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
13022 ffebld_nonter_set_hook (expr
, tempvar
);
13023 current_binding_level
->prep_state
= 1;
13026 /* Prepare subexpressions for this expr. */
13028 switch (ffebld_op (expr
))
13030 case FFEBLD_opPERCENT_LOC
:
13031 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
13034 case FFEBLD_opPERCENT_VAL
:
13035 case FFEBLD_opPERCENT_REF
:
13036 ffecom_prepare_expr (ffebld_left (expr
));
13039 case FFEBLD_opPERCENT_DESCR
:
13040 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
13043 case FFEBLD_opITEM
:
13049 item
= ffebld_trail (item
))
13050 if (ffebld_head (item
) != NULL
)
13051 ffecom_prepare_expr (ffebld_head (item
));
13056 /* Need to handle character conversion specially. */
13057 switch (ffebld_arity (expr
))
13060 ffecom_prepare_expr (ffebld_left (expr
));
13061 ffecom_prepare_expr (ffebld_right (expr
));
13065 ffecom_prepare_expr (ffebld_left (expr
));
13076 /* Prepare expression for reading and writing.
13078 Like ffecom_prepare_expr, except for expressions to be evaluated
13079 via ffecom_expr_rw. */
13082 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
13084 /* This is all we support for now. */
13085 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
13087 /* ~~For now, it seems to be the same thing. */
13088 ffecom_prepare_expr (expr
);
13092 /* Prepare expression for writing.
13094 Like ffecom_prepare_expr, except for expressions to be evaluated
13095 via ffecom_expr_w. */
13098 ffecom_prepare_expr_w (tree type
, ffebld expr
)
13100 /* This is all we support for now. */
13101 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
13103 /* ~~For now, it seems to be the same thing. */
13104 ffecom_prepare_expr (expr
);
13108 /* Prepare expression for returning.
13110 Like ffecom_prepare_expr, except for expressions to be evaluated
13111 via ffecom_return_expr. */
13114 ffecom_prepare_return_expr (ffebld expr
)
13116 assert (current_binding_level
->prep_state
< 2);
13118 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
13119 && ffecom_is_altreturning_
13121 ffecom_prepare_expr (expr
);
13124 /* Prepare pointer to expression.
13126 Like ffecom_prepare_expr, except for expressions to be evaluated
13127 via ffecom_ptr_to_expr. */
13130 ffecom_prepare_ptr_to_expr (ffebld expr
)
13132 /* ~~For now, it seems to be the same thing. */
13133 ffecom_prepare_expr (expr
);
13137 /* Transform expression into constant pointer-to-expression tree.
13139 If the expression can be transformed into a pointer-to-expression tree
13140 that is constant, that is done, and the tree returned. Else NULL_TREE
13143 That way, a caller can attempt to provide compile-time initialization
13144 of a variable and, if that fails, *then* choose to start a new block
13145 and resort to using temporaries, as appropriate. */
13148 ffecom_ptr_to_const_expr (ffebld expr
)
13151 return integer_zero_node
;
13153 if (ffebld_op (expr
) == FFEBLD_opANY
)
13154 return error_mark_node
;
13156 if (ffebld_arity (expr
) == 0
13157 && (ffebld_op (expr
) != FFEBLD_opSYMTER
13158 || ffebld_where (expr
) == FFEINFO_whereCOMMON
13159 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
13160 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
13164 t
= ffecom_ptr_to_expr (expr
);
13165 assert (TREE_CONSTANT (t
));
13172 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13174 tree rtn; // NULL_TREE means use expand_null_return()
13175 ffebld expr; // NULL if no alt return expr to RETURN stmt
13176 rtn = ffecom_return_expr(expr);
13178 Based on the program unit type and other info (like return function
13179 type, return master function type when alternate ENTRY points,
13180 whether subroutine has any alternate RETURN points, etc), returns the
13181 appropriate expression to be returned to the caller, or NULL_TREE
13182 meaning no return value or the caller expects it to be returned somewhere
13183 else (which is handled by other parts of this module). */
13185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13187 ffecom_return_expr (ffebld expr
)
13191 switch (ffecom_primary_entry_kind_
)
13193 case FFEINFO_kindPROGRAM
:
13194 case FFEINFO_kindBLOCKDATA
:
13198 case FFEINFO_kindSUBROUTINE
:
13199 if (!ffecom_is_altreturning_
)
13200 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13201 else if (expr
== NULL
)
13202 rtn
= integer_zero_node
;
13204 rtn
= ffecom_expr (expr
);
13207 case FFEINFO_kindFUNCTION
:
13208 if ((ffecom_multi_retval_
!= NULL_TREE
)
13209 || (ffesymbol_basictype (ffecom_primary_entry_
)
13210 == FFEINFO_basictypeCHARACTER
)
13211 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13212 == FFEINFO_basictypeCOMPLEX
)
13213 && (ffecom_num_entrypoints_
== 0)
13214 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13215 { /* Value is returned by direct assignment
13216 into (implicit) dummy. */
13220 rtn
= ffecom_func_result_
;
13222 /* Spurious error if RETURN happens before first reference! So elide
13223 this code. In particular, for debugging registry, rtn should always
13224 be non-null after all, but TREE_USED won't be set until we encounter
13225 a reference in the code. Perfectly okay (but weird) code that,
13226 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13227 this diagnostic for no reason. Have people use -O -Wuninitialized
13228 and leave it to the back end to find obviously weird cases. */
13230 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13231 situation; if the return value has never been referenced, it won't
13232 have a tree under 2pass mode. */
13233 if ((rtn
== NULL_TREE
)
13234 || !TREE_USED (rtn
))
13236 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13237 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13238 ffesymbol_where_column (ffecom_primary_entry_
));
13239 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13240 (ffecom_primary_entry_
)));
13247 assert ("bad unit kind" == NULL
);
13248 case FFEINFO_kindANY
:
13249 rtn
= error_mark_node
;
13257 /* Do save_expr only if tree is not error_mark_node. */
13259 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13261 ffecom_save_tree (tree t
)
13263 return save_expr (t
);
13267 /* Start a compound statement (block). */
13269 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13271 ffecom_start_compstmt (void)
13273 bison_rule_pushlevel_ ();
13275 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13277 /* Public entry point for front end to access start_decl. */
13279 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13281 ffecom_start_decl (tree decl
, bool is_initialized
)
13283 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13284 return start_decl (decl
, FALSE
);
13288 /* ffecom_sym_commit -- Symbol's state being committed to reality
13291 ffecom_sym_commit(s);
13293 Does whatever the backend needs when a symbol is committed after having
13294 been backtrackable for a period of time. */
13296 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13298 ffecom_sym_commit (ffesymbol s UNUSED
)
13300 assert (!ffesymbol_retractable ());
13304 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13306 ffecom_sym_end_transition();
13308 Does backend-specific stuff and also calls ffest_sym_end_transition
13309 to do the necessary FFE stuff.
13311 Backtracking is never enabled when this fn is called, so don't worry
13315 ffecom_sym_end_transition (ffesymbol s
)
13319 assert (!ffesymbol_retractable ());
13321 s
= ffest_sym_end_transition (s
);
13323 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13324 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13325 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13327 ffecom_list_blockdata_
13328 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13329 FFEINTRIN_specNONE
,
13330 FFEINTRIN_impNONE
),
13331 ffecom_list_blockdata_
);
13335 /* This is where we finally notice that a symbol has partial initialization
13336 and finalize it. */
13338 if (ffesymbol_accretion (s
) != NULL
)
13340 assert (ffesymbol_init (s
) == NULL
);
13341 ffecom_notify_init_symbol (s
);
13343 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13344 && ((st
= ffestorag_parent (st
)) != NULL
)
13345 && (ffestorag_accretion (st
) != NULL
))
13347 assert (ffestorag_init (st
) == NULL
);
13348 ffecom_notify_init_storage (st
);
13351 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13352 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13353 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13354 && (ffesymbol_storage (s
) != NULL
))
13356 ffecom_list_common_
13357 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13358 FFEINTRIN_specNONE
,
13359 FFEINTRIN_impNONE
),
13360 ffecom_list_common_
);
13367 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13369 ffecom_sym_exec_transition();
13371 Does backend-specific stuff and also calls ffest_sym_exec_transition
13372 to do the necessary FFE stuff.
13374 See the long-winded description in ffecom_sym_learned for info
13375 on handling the situation where backtracking is inhibited. */
13378 ffecom_sym_exec_transition (ffesymbol s
)
13380 s
= ffest_sym_exec_transition (s
);
13385 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13388 s = ffecom_sym_learned(s);
13390 Called when a new symbol is seen after the exec transition or when more
13391 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13392 it arrives here is that all its latest info is updated already, so its
13393 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13394 field filled in if its gone through here or exec_transition first, and
13397 The backend probably wants to check ffesymbol_retractable() to see if
13398 backtracking is in effect. If so, the FFE's changes to the symbol may
13399 be retracted (undone) or committed (ratified), at which time the
13400 appropriate ffecom_sym_retract or _commit function will be called
13403 If the backend has its own backtracking mechanism, great, use it so that
13404 committal is a simple operation. Though it doesn't make much difference,
13405 I suppose: the reason for tentative symbol evolution in the FFE is to
13406 enable error detection in weird incorrect statements early and to disable
13407 incorrect error detection on a correct statement. The backend is not
13408 likely to introduce any information that'll get involved in these
13409 considerations, so it is probably just fine that the implementation
13410 model for this fn and for _exec_transition is to not do anything
13411 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13412 and instead wait until ffecom_sym_commit is called (which it never
13413 will be as long as we're using ambiguity-detecting statement analysis in
13414 the FFE, which we are initially to shake out the code, but don't depend
13415 on this), otherwise go ahead and do whatever is needed.
13417 In essence, then, when this fn and _exec_transition get called while
13418 backtracking is enabled, a general mechanism would be to flag which (or
13419 both) of these were called (and in what order? neat question as to what
13420 might happen that I'm too lame to think through right now) and then when
13421 _commit is called reproduce the original calling sequence, if any, for
13422 the two fns (at which point backtracking will, of course, be disabled). */
13425 ffecom_sym_learned (ffesymbol s
)
13427 ffestorag_exec_layout (s
);
13432 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13435 ffecom_sym_retract(s);
13437 Does whatever the backend needs when a symbol is retracted after having
13438 been backtrackable for a period of time. */
13440 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13442 ffecom_sym_retract (ffesymbol s UNUSED
)
13444 assert (!ffesymbol_retractable ());
13446 #if 0 /* GCC doesn't commit any backtrackable sins,
13447 so nothing needed here. */
13448 switch (ffesymbol_hook (s
).state
)
13450 case 0: /* nothing happened yet. */
13453 case 1: /* exec transition happened. */
13456 case 2: /* learned happened. */
13459 case 3: /* learned then exec. */
13462 case 4: /* exec then learned. */
13466 assert ("bad hook state" == NULL
);
13473 /* Create temporary gcc label. */
13475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13477 ffecom_temp_label ()
13480 static int mynumber
= 0;
13482 glabel
= build_decl (LABEL_DECL
,
13483 ffecom_get_invented_identifier ("__g77_label_%d",
13486 DECL_CONTEXT (glabel
) = current_function_decl
;
13487 DECL_MODE (glabel
) = VOIDmode
;
13493 /* Return an expression that is usable as an arg in a conditional context
13494 (IF, DO WHILE, .NOT., and so on).
13496 Use the one provided for the back end as of >2.6.0. */
13498 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13500 ffecom_truth_value (tree expr
)
13502 return truthvalue_conversion (expr
);
13506 /* Return the inversion of a truth value (the inversion of what
13507 ffecom_truth_value builds).
13509 Apparently invert_truthvalue, which is properly in the back end, is
13510 enough for now, so just use it. */
13512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13514 ffecom_truth_value_invert (tree expr
)
13516 return invert_truthvalue (ffecom_truth_value (expr
));
13521 /* Return the tree that is the type of the expression, as would be
13522 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13523 transforming the expression, generating temporaries, etc. */
13526 ffecom_type_expr (ffebld expr
)
13528 ffeinfoBasictype bt
;
13529 ffeinfoKindtype kt
;
13532 assert (expr
!= NULL
);
13534 bt
= ffeinfo_basictype (ffebld_info (expr
));
13535 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13536 tree_type
= ffecom_tree_type
[bt
][kt
];
13538 switch (ffebld_op (expr
))
13540 case FFEBLD_opCONTER
:
13541 case FFEBLD_opSYMTER
:
13542 case FFEBLD_opARRAYREF
:
13543 case FFEBLD_opUPLUS
:
13544 case FFEBLD_opPAREN
:
13545 case FFEBLD_opUMINUS
:
13547 case FFEBLD_opSUBTRACT
:
13548 case FFEBLD_opMULTIPLY
:
13549 case FFEBLD_opDIVIDE
:
13550 case FFEBLD_opPOWER
:
13552 case FFEBLD_opFUNCREF
:
13553 case FFEBLD_opSUBRREF
:
13557 case FFEBLD_opNEQV
:
13559 case FFEBLD_opCONVERT
:
13566 case FFEBLD_opPERCENT_LOC
:
13569 case FFEBLD_opACCTER
:
13570 case FFEBLD_opARRTER
:
13571 case FFEBLD_opITEM
:
13572 case FFEBLD_opSTAR
:
13573 case FFEBLD_opBOUNDS
:
13574 case FFEBLD_opREPEAT
:
13575 case FFEBLD_opLABTER
:
13576 case FFEBLD_opLABTOK
:
13577 case FFEBLD_opIMPDO
:
13578 case FFEBLD_opCONCATENATE
:
13579 case FFEBLD_opSUBSTR
:
13581 assert ("bad op for ffecom_type_expr" == NULL
);
13582 /* Fall through. */
13584 return error_mark_node
;
13588 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13590 If the PARM_DECL already exists, return it, else create it. It's an
13591 integer_type_node argument for the master function that implements a
13592 subroutine or function with more than one entrypoint and is bound at
13593 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13594 first ENTRY statement, and so on). */
13596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13598 ffecom_which_entrypoint_decl ()
13600 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13602 return ffecom_which_entrypoint_decl_
;
13607 /* The following sections consists of private and public functions
13608 that have the same names and perform roughly the same functions
13609 as counterparts in the C front end. Changes in the C front end
13610 might affect how things should be done here. Only functions
13611 needed by the back end should be public here; the rest should
13612 be private (static in the C sense). Functions needed by other
13613 g77 front-end modules should be accessed by them via public
13614 ffecom_* names, which should themselves call private versions
13615 in this section so the private versions are easy to recognize
13616 when upgrading to a new gcc and finding interesting changes
13619 Functions named after rule "foo:" in c-parse.y are named
13620 "bison_rule_foo_" so they are easy to find. */
13622 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13625 bison_rule_pushlevel_ ()
13627 emit_line_note (input_filename
, lineno
);
13629 clear_last_expr ();
13631 expand_start_bindings (0);
13635 bison_rule_compstmt_ ()
13638 int keep
= kept_level_p ();
13640 /* Make the temps go away. */
13642 current_binding_level
->names
= NULL_TREE
;
13644 emit_line_note (input_filename
, lineno
);
13645 expand_end_bindings (getdecls (), keep
, 0);
13646 t
= poplevel (keep
, 1, 0);
13652 /* Return a definition for a builtin function named NAME and whose data type
13653 is TYPE. TYPE should be a function type with argument types.
13654 FUNCTION_CODE tells later passes how to compile calls to this function.
13655 See tree.h for its possible values.
13657 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13658 the name to be called if we can't opencode the function. */
13661 builtin_function (const char *name
, tree type
, int function_code
,
13662 enum built_in_class
class,
13663 const char *library_name
)
13665 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13666 DECL_EXTERNAL (decl
) = 1;
13667 TREE_PUBLIC (decl
) = 1;
13669 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13670 make_decl_rtl (decl
, NULL_PTR
, 1);
13672 DECL_BUILT_IN_CLASS (decl
) = class;
13673 DECL_FUNCTION_CODE (decl
) = function_code
;
13678 /* Handle when a new declaration NEWDECL
13679 has the same name as an old one OLDDECL
13680 in the same binding contour.
13681 Prints an error message if appropriate.
13683 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13684 Otherwise, return 0. */
13687 duplicate_decls (tree newdecl
, tree olddecl
)
13689 int types_match
= 1;
13690 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13691 && DECL_INITIAL (newdecl
) != 0);
13692 tree oldtype
= TREE_TYPE (olddecl
);
13693 tree newtype
= TREE_TYPE (newdecl
);
13695 if (olddecl
== newdecl
)
13698 if (TREE_CODE (newtype
) == ERROR_MARK
13699 || TREE_CODE (oldtype
) == ERROR_MARK
)
13702 /* New decl is completely inconsistent with the old one =>
13703 tell caller to replace the old one.
13704 This is always an error except in the case of shadowing a builtin. */
13705 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13708 /* For real parm decl following a forward decl,
13709 return 1 so old decl will be reused. */
13710 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13711 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13714 /* The new declaration is the same kind of object as the old one.
13715 The declarations may partially match. Print warnings if they don't
13716 match enough. Ultimately, copy most of the information from the new
13717 decl to the old one, and keep using the old one. */
13719 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13720 && DECL_BUILT_IN (olddecl
))
13722 /* A function declaration for a built-in function. */
13723 if (!TREE_PUBLIC (newdecl
))
13725 else if (!types_match
)
13727 /* Accept the return type of the new declaration if same modes. */
13728 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13729 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13731 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13733 /* Function types may be shared, so we can't just modify
13734 the return type of olddecl's function type. */
13736 = build_function_type (newreturntype
,
13737 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13741 TREE_TYPE (olddecl
) = newtype
;
13747 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13748 && DECL_SOURCE_LINE (olddecl
) == 0)
13750 /* A function declaration for a predeclared function
13751 that isn't actually built in. */
13752 if (!TREE_PUBLIC (newdecl
))
13754 else if (!types_match
)
13756 /* If the types don't match, preserve volatility indication.
13757 Later on, we will discard everything else about the
13758 default declaration. */
13759 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13763 /* Copy all the DECL_... slots specified in the new decl
13764 except for any that we copy here from the old type.
13766 Past this point, we don't change OLDTYPE and NEWTYPE
13767 even if we change the types of NEWDECL and OLDDECL. */
13771 /* Merge the data types specified in the two decls. */
13772 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13773 TREE_TYPE (newdecl
)
13774 = TREE_TYPE (olddecl
)
13775 = TREE_TYPE (newdecl
);
13777 /* Lay the type out, unless already done. */
13778 if (oldtype
!= TREE_TYPE (newdecl
))
13780 if (TREE_TYPE (newdecl
) != error_mark_node
)
13781 layout_type (TREE_TYPE (newdecl
));
13782 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13783 && TREE_CODE (newdecl
) != TYPE_DECL
13784 && TREE_CODE (newdecl
) != CONST_DECL
)
13785 layout_decl (newdecl
, 0);
13789 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13790 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13791 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13792 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13793 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13795 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13796 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13800 /* Keep the old rtl since we can safely use it. */
13801 DECL_RTL (newdecl
) = DECL_RTL (olddecl
);
13803 /* Merge the type qualifiers. */
13804 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13805 && !TREE_THIS_VOLATILE (newdecl
))
13806 TREE_THIS_VOLATILE (olddecl
) = 0;
13807 if (TREE_READONLY (newdecl
))
13808 TREE_READONLY (olddecl
) = 1;
13809 if (TREE_THIS_VOLATILE (newdecl
))
13811 TREE_THIS_VOLATILE (olddecl
) = 1;
13812 if (TREE_CODE (newdecl
) == VAR_DECL
)
13813 make_var_volatile (newdecl
);
13816 /* Keep source location of definition rather than declaration.
13817 Likewise, keep decl at outer scope. */
13818 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13819 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13821 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13822 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13824 if (DECL_CONTEXT (olddecl
) == 0
13825 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13826 DECL_CONTEXT (newdecl
) = 0;
13829 /* Merge the unused-warning information. */
13830 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13831 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13832 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13833 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13835 /* Merge the initialization information. */
13836 if (DECL_INITIAL (newdecl
) == 0)
13837 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13839 /* Merge the section attribute.
13840 We want to issue an error if the sections conflict but that must be
13841 done later in decl_attributes since we are called before attributes
13843 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13844 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13847 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13849 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13850 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13854 /* If cannot merge, then use the new type and qualifiers,
13855 and don't preserve the old rtl. */
13858 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13859 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13860 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13861 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13864 /* Merge the storage class information. */
13865 /* For functions, static overrides non-static. */
13866 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13868 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13869 /* This is since we don't automatically
13870 copy the attributes of NEWDECL into OLDDECL. */
13871 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13872 /* If this clears `static', clear it in the identifier too. */
13873 if (! TREE_PUBLIC (olddecl
))
13874 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13876 if (DECL_EXTERNAL (newdecl
))
13878 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13879 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13880 /* An extern decl does not override previous storage class. */
13881 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13885 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13886 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13889 /* If either decl says `inline', this fn is inline,
13890 unless its definition was passed already. */
13891 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13892 DECL_INLINE (olddecl
) = 1;
13893 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13895 /* Get rid of any built-in function if new arg types don't match it
13896 or if we have a function definition. */
13897 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13898 && DECL_BUILT_IN (olddecl
)
13899 && (!types_match
|| new_is_definition
))
13901 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13902 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13905 /* If redeclaring a builtin function, and not a definition,
13907 Also preserve various other info from the definition. */
13908 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13910 if (DECL_BUILT_IN (olddecl
))
13912 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13913 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13916 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
13918 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13919 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13920 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13921 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13924 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13925 But preserve olddecl's DECL_UID. */
13927 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13929 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13930 (char *) newdecl
+ sizeof (struct tree_common
),
13931 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13932 DECL_UID (olddecl
) = olddecl_uid
;
13938 /* Finish processing of a declaration;
13939 install its initial value.
13940 If the length of an array type is not known before,
13941 it must be determined now, from the initial value, or it is an error. */
13944 finish_decl (tree decl
, tree init
, bool is_top_level
)
13946 register tree type
= TREE_TYPE (decl
);
13947 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13948 int temporary
= allocation_temporary_p ();
13949 bool at_top_level
= (current_binding_level
== global_binding_level
);
13950 bool top_level
= is_top_level
|| at_top_level
;
13952 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13954 assert (!is_top_level
|| !at_top_level
);
13956 if (TREE_CODE (decl
) == PARM_DECL
)
13957 assert (init
== NULL_TREE
);
13958 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13959 overlaps DECL_ARG_TYPE. */
13960 else if (init
== NULL_TREE
)
13961 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13963 assert (DECL_INITIAL (decl
) == error_mark_node
);
13965 if (init
!= NULL_TREE
)
13967 if (TREE_CODE (decl
) != TYPE_DECL
)
13968 DECL_INITIAL (decl
) = init
;
13971 /* typedef foo = bar; store the type of bar as the type of foo. */
13972 TREE_TYPE (decl
) = TREE_TYPE (init
);
13973 DECL_INITIAL (decl
) = init
= 0;
13977 /* Pop back to the obstack that is current for this binding level. This is
13978 because MAXINDEX, rtl, etc. to be made below must go in the permanent
13979 obstack. But don't discard the temporary data yet. */
13982 /* Deduce size of array from initialization, if not already known */
13984 if (TREE_CODE (type
) == ARRAY_TYPE
13985 && TYPE_DOMAIN (type
) == 0
13986 && TREE_CODE (decl
) != TYPE_DECL
)
13988 assert (top_level
);
13989 assert (was_incomplete
);
13991 layout_decl (decl
, 0);
13994 if (TREE_CODE (decl
) == VAR_DECL
)
13996 if (DECL_SIZE (decl
) == NULL_TREE
13997 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13998 layout_decl (decl
, 0);
14000 if (DECL_SIZE (decl
) == NULL_TREE
14001 && (TREE_STATIC (decl
)
14003 /* A static variable with an incomplete type is an error if it is
14004 initialized. Also if it is not file scope. Otherwise, let it
14005 through, but if it is not `extern' then it may cause an error
14007 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
14009 /* An automatic variable with an incomplete type is an error. */
14010 !DECL_EXTERNAL (decl
)))
14012 assert ("storage size not known" == NULL
);
14016 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
14017 && (DECL_SIZE (decl
) != 0)
14018 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
14020 assert ("storage size not constant" == NULL
);
14025 /* Output the assembler code and/or RTL code for variables and functions,
14026 unless the type is an undefined structure or union. If not, it will get
14027 done when the type is completed. */
14029 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
14031 rest_of_decl_compilation (decl
, NULL
,
14032 DECL_CONTEXT (decl
) == 0,
14035 if (DECL_CONTEXT (decl
) != 0)
14037 /* Recompute the RTL of a local array now if it used to be an
14038 incomplete type. */
14040 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
14042 /* If we used it already as memory, it must stay in memory. */
14043 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
14044 /* If it's still incomplete now, no init will save it. */
14045 if (DECL_SIZE (decl
) == 0)
14046 DECL_INITIAL (decl
) = 0;
14047 expand_decl (decl
);
14049 /* Compute and store the initial value. */
14050 if (TREE_CODE (decl
) != FUNCTION_DECL
)
14051 expand_decl_init (decl
);
14054 else if (TREE_CODE (decl
) == TYPE_DECL
)
14056 rest_of_decl_compilation (decl
, NULL_PTR
,
14057 DECL_CONTEXT (decl
) == 0,
14061 if (!(TREE_CODE (decl
) == FUNCTION_DECL
&& DECL_INLINE (decl
))
14063 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14065 && TREE_CODE (decl
) != PARM_DECL
)
14067 /* We need to remember that this array HAD an initialization, but
14068 discard the actual temporary nodes, since we can't have a permanent
14069 node keep pointing to them. */
14070 /* We make an exception for inline functions, since it's normal for a
14071 local extern redeclaration of an inline function to have a copy of
14072 the top-level decl's DECL_INLINE. */
14073 if ((DECL_INITIAL (decl
) != 0)
14074 && (DECL_INITIAL (decl
) != error_mark_node
))
14076 /* If this is a const variable, then preserve the
14077 initializer instead of discarding it so that we can optimize
14078 references to it. */
14079 /* This test used to include TREE_STATIC, but this won't be set
14080 for function level initializers. */
14081 if (TREE_READONLY (decl
))
14083 preserve_initializer ();
14085 /* The initializer and DECL must have the same (or equivalent
14086 types), but if the initializer is a STRING_CST, its type
14087 might not be on the right obstack, so copy the type
14089 TREE_TYPE (DECL_INITIAL (decl
)) = type
;
14092 DECL_INITIAL (decl
) = error_mark_node
;
14096 /* If we have gone back from temporary to permanent allocation, actually
14097 free the temporary space that we no longer need. */
14098 if (temporary
&& !allocation_temporary_p ())
14099 permanent_allocation (0);
14101 /* At the end of a declaration, throw away any variable type sizes of types
14102 defined inside that declaration. There is no use computing them in the
14103 following function definition. */
14104 if (current_binding_level
== global_binding_level
)
14105 get_pending_sizes ();
14108 /* Finish up a function declaration and compile that function
14109 all the way to assembler language output. The free the storage
14110 for the function definition.
14112 This is called after parsing the body of the function definition.
14114 NESTED is nonzero if the function being finished is nested in another. */
14117 finish_function (int nested
)
14119 register tree fndecl
= current_function_decl
;
14121 assert (fndecl
!= NULL_TREE
);
14122 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14125 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
14127 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
14130 /* TREE_READONLY (fndecl) = 1;
14131 This caused &foo to be of type ptr-to-const-function
14132 which then got a warning when stored in a ptr-to-function variable. */
14134 poplevel (1, 0, 1);
14136 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14138 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
14140 /* Must mark the RESULT_DECL as being in this function. */
14142 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
14144 /* Obey `register' declarations if `setjmp' is called in this fn. */
14145 /* Generate rtl for function exit. */
14146 expand_function_end (input_filename
, lineno
, 0);
14148 /* So we can tell if jump_optimize sets it to 1. */
14151 /* If this is a nested function, protect the local variables in the stack
14152 above us from being collected while we're compiling this function. */
14153 if (ggc_p
&& nested
)
14154 ggc_push_context ();
14156 /* Run the optimizers and output the assembler code for this function. */
14157 rest_of_compilation (fndecl
);
14159 /* Undo the GC context switch. */
14160 if (ggc_p
&& nested
)
14161 ggc_pop_context ();
14164 /* Free all the tree nodes making up this function. */
14165 /* Switch back to allocating nodes permanently until we start another
14168 permanent_allocation (1);
14170 if (TREE_CODE (fndecl
) != ERROR_MARK
14172 && DECL_SAVED_INSNS (fndecl
) == 0)
14174 /* Stop pointing to the local nodes about to be freed. */
14175 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14176 function definition. */
14177 /* For a nested function, this is done in pop_f_function_context. */
14178 /* If rest_of_compilation set this to 0, leave it 0. */
14179 if (DECL_INITIAL (fndecl
) != 0)
14180 DECL_INITIAL (fndecl
) = error_mark_node
;
14181 DECL_ARGUMENTS (fndecl
) = 0;
14186 /* Let the error reporting routines know that we're outside a function.
14187 For a nested function, this value is used in pop_c_function_context
14188 and then reset via pop_function_context. */
14189 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
14193 /* Plug-in replacement for identifying the name of a decl and, for a
14194 function, what we call it in diagnostics. For now, "program unit"
14195 should suffice, since it's a bit of a hassle to figure out which
14196 of several kinds of things it is. Note that it could conceivably
14197 be a statement function, which probably isn't really a program unit
14198 per se, but if that comes up, it should be easy to check (being a
14199 nested function and all). */
14201 static const char *
14202 lang_printable_name (tree decl
, int v
)
14204 /* Just to keep GCC quiet about the unused variable.
14205 In theory, differing values of V should produce different
14210 if (TREE_CODE (decl
) == ERROR_MARK
)
14211 return "erroneous code";
14212 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14216 /* g77's function to print out name of current function that caused
14221 lang_print_error_function (const char *file
)
14223 static ffeglobal last_g
= NULL
;
14224 static ffesymbol last_s
= NULL
;
14229 if ((ffecom_primary_entry_
== NULL
)
14230 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14238 g
= ffesymbol_global (ffecom_primary_entry_
);
14239 if (ffecom_nested_entry_
== NULL
)
14241 s
= ffecom_primary_entry_
;
14242 switch (ffesymbol_kind (s
))
14244 case FFEINFO_kindFUNCTION
:
14248 case FFEINFO_kindSUBROUTINE
:
14249 kind
= "subroutine";
14252 case FFEINFO_kindPROGRAM
:
14256 case FFEINFO_kindBLOCKDATA
:
14257 kind
= "block-data";
14261 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14267 s
= ffecom_nested_entry_
;
14268 kind
= "statement function";
14272 if ((last_g
!= g
) || (last_s
!= s
))
14275 fprintf (stderr
, "%s: ", file
);
14278 fprintf (stderr
, "Outside of any program unit:\n");
14281 const char *name
= ffesymbol_text (s
);
14283 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14292 /* Similar to `lookup_name' but look only at current binding level. */
14295 lookup_name_current_level (tree name
)
14299 if (current_binding_level
== global_binding_level
)
14300 return IDENTIFIER_GLOBAL_VALUE (name
);
14302 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14305 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14306 if (DECL_NAME (t
) == name
)
14312 /* Create a new `struct binding_level'. */
14314 static struct binding_level
*
14315 make_binding_level ()
14318 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14321 /* Save and restore the variables in this file and elsewhere
14322 that keep track of the progress of compilation of the current function.
14323 Used for nested functions. */
14327 struct f_function
*next
;
14329 tree shadowed_labels
;
14330 struct binding_level
*binding_level
;
14333 struct f_function
*f_function_chain
;
14335 /* Restore the variables used during compilation of a C function. */
14338 pop_f_function_context ()
14340 struct f_function
*p
= f_function_chain
;
14343 /* Bring back all the labels that were shadowed. */
14344 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14345 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14346 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14347 = TREE_VALUE (link
);
14349 if (current_function_decl
!= error_mark_node
14350 && DECL_SAVED_INSNS (current_function_decl
) == 0)
14352 /* Stop pointing to the local nodes about to be freed. */
14353 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14354 function definition. */
14355 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14356 DECL_ARGUMENTS (current_function_decl
) = 0;
14359 pop_function_context ();
14361 f_function_chain
= p
->next
;
14363 named_labels
= p
->named_labels
;
14364 shadowed_labels
= p
->shadowed_labels
;
14365 current_binding_level
= p
->binding_level
;
14370 /* Save and reinitialize the variables
14371 used during compilation of a C function. */
14374 push_f_function_context ()
14376 struct f_function
*p
14377 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14379 push_function_context ();
14381 p
->next
= f_function_chain
;
14382 f_function_chain
= p
;
14384 p
->named_labels
= named_labels
;
14385 p
->shadowed_labels
= shadowed_labels
;
14386 p
->binding_level
= current_binding_level
;
14390 push_parm_decl (tree parm
)
14392 int old_immediate_size_expand
= immediate_size_expand
;
14394 /* Don't try computing parm sizes now -- wait till fn is called. */
14396 immediate_size_expand
= 0;
14398 push_obstacks_nochange ();
14400 /* Fill in arg stuff. */
14402 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14403 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14404 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14406 parm
= pushdecl (parm
);
14408 immediate_size_expand
= old_immediate_size_expand
;
14410 finish_decl (parm
, NULL_TREE
, FALSE
);
14413 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14416 pushdecl_top_level (x
)
14420 register struct binding_level
*b
= current_binding_level
;
14421 register tree f
= current_function_decl
;
14423 current_binding_level
= global_binding_level
;
14424 current_function_decl
= NULL_TREE
;
14426 current_binding_level
= b
;
14427 current_function_decl
= f
;
14431 /* Store the list of declarations of the current level.
14432 This is done for the parameter declarations of a function being defined,
14433 after they are modified in the light of any missing parameters. */
14439 return current_binding_level
->names
= decls
;
14442 /* Store the parameter declarations into the current function declaration.
14443 This is called after parsing the parameter declarations, before
14444 digesting the body of the function.
14446 For an old-style definition, modify the function's type
14447 to specify at least the number of arguments. */
14450 store_parm_decls (int is_main_program UNUSED
)
14452 register tree fndecl
= current_function_decl
;
14454 if (fndecl
== error_mark_node
)
14457 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14458 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14460 /* Initialize the RTL code for the function. */
14462 init_function_start (fndecl
, input_filename
, lineno
);
14464 /* Set up parameters and prepare for return, for the function. */
14466 expand_function_start (fndecl
, 0);
14470 start_decl (tree decl
, bool is_top_level
)
14473 bool at_top_level
= (current_binding_level
== global_binding_level
);
14474 bool top_level
= is_top_level
|| at_top_level
;
14476 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14478 assert (!is_top_level
|| !at_top_level
);
14480 /* The corresponding pop_obstacks is in finish_decl. */
14481 push_obstacks_nochange ();
14483 if (DECL_INITIAL (decl
) != NULL_TREE
)
14485 assert (DECL_INITIAL (decl
) == error_mark_node
);
14486 assert (!DECL_EXTERNAL (decl
));
14488 else if (top_level
)
14489 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14491 /* For Fortran, we by default put things in .common when possible. */
14492 DECL_COMMON (decl
) = 1;
14494 /* Add this decl to the current binding level. TEM may equal DECL or it may
14495 be a previous decl of the same name. */
14497 tem
= pushdecl_top_level (decl
);
14499 tem
= pushdecl (decl
);
14501 /* For a local variable, define the RTL now. */
14503 /* But not if this is a duplicate decl and we preserved the rtl from the
14504 previous one (which may or may not happen). */
14505 && DECL_RTL (tem
) == 0)
14507 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14509 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14510 && DECL_INITIAL (tem
) != 0)
14514 if (DECL_INITIAL (tem
) != NULL_TREE
)
14516 /* When parsing and digesting the initializer, use temporary storage.
14517 Do this even if we will ignore the value. */
14519 temporary_allocation ();
14525 /* Create the FUNCTION_DECL for a function definition.
14526 DECLSPECS and DECLARATOR are the parts of the declaration;
14527 they describe the function's name and the type it returns,
14528 but twisted together in a fashion that parallels the syntax of C.
14530 This function creates a binding context for the function body
14531 as well as setting up the FUNCTION_DECL in current_function_decl.
14533 Returns 1 on success. If the DECLARATOR is not suitable for a function
14534 (it defines a datum instead), we return 0, which tells
14535 yyparse to report a parse error.
14537 NESTED is nonzero for a function nested within another function. */
14540 start_function (tree name
, tree type
, int nested
, int public)
14544 int old_immediate_size_expand
= immediate_size_expand
;
14547 shadowed_labels
= 0;
14549 /* Don't expand any sizes in the return type of the function. */
14550 immediate_size_expand
= 0;
14555 assert (current_function_decl
!= NULL_TREE
);
14556 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14560 assert (current_function_decl
== NULL_TREE
);
14563 if (TREE_CODE (type
) == ERROR_MARK
)
14564 decl1
= current_function_decl
= error_mark_node
;
14567 decl1
= build_decl (FUNCTION_DECL
,
14570 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14572 DECL_INLINE (decl1
) = 1;
14573 TREE_STATIC (decl1
) = 1;
14574 DECL_EXTERNAL (decl1
) = 0;
14576 announce_function (decl1
);
14578 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14579 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14580 DECL_INITIAL (decl1
) = error_mark_node
;
14582 /* Record the decl so that the function name is defined. If we already have
14583 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14585 current_function_decl
= pushdecl (decl1
);
14589 ffecom_outer_function_decl_
= current_function_decl
;
14592 current_binding_level
->prep_state
= 2;
14594 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14596 make_function_rtl (current_function_decl
);
14598 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14599 DECL_RESULT (current_function_decl
)
14600 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14604 /* Allocate further tree nodes temporarily during compilation of this
14606 temporary_allocation ();
14608 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14609 TREE_ADDRESSABLE (current_function_decl
) = 1;
14611 immediate_size_expand
= old_immediate_size_expand
;
14614 /* Here are the public functions the GNU back end needs. */
14617 convert (type
, expr
)
14620 register tree e
= expr
;
14621 register enum tree_code code
= TREE_CODE (type
);
14623 if (type
== TREE_TYPE (e
)
14624 || TREE_CODE (e
) == ERROR_MARK
)
14626 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14627 return fold (build1 (NOP_EXPR
, type
, e
));
14628 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14629 || code
== ERROR_MARK
)
14630 return error_mark_node
;
14631 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14633 assert ("void value not ignored as it ought to be" == NULL
);
14634 return error_mark_node
;
14636 if (code
== VOID_TYPE
)
14637 return build1 (CONVERT_EXPR
, type
, e
);
14638 if ((code
!= RECORD_TYPE
)
14639 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14640 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14642 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14643 return fold (convert_to_integer (type
, e
));
14644 if (code
== POINTER_TYPE
)
14645 return fold (convert_to_pointer (type
, e
));
14646 if (code
== REAL_TYPE
)
14647 return fold (convert_to_real (type
, e
));
14648 if (code
== COMPLEX_TYPE
)
14649 return fold (convert_to_complex (type
, e
));
14650 if (code
== RECORD_TYPE
)
14651 return fold (ffecom_convert_to_complex_ (type
, e
));
14653 assert ("conversion to non-scalar type requested" == NULL
);
14654 return error_mark_node
;
14657 /* integrate_decl_tree calls this function, but since we don't use the
14658 DECL_LANG_SPECIFIC field, this is a no-op. */
14661 copy_lang_decl (node
)
14666 /* Return the list of declarations of the current level.
14667 Note that this list is in reverse order unless/until
14668 you nreverse it; and when you do nreverse it, you must
14669 store the result back using `storedecls' or you will lose. */
14674 return current_binding_level
->names
;
14677 /* Nonzero if we are currently in the global binding level. */
14680 global_bindings_p ()
14682 return current_binding_level
== global_binding_level
;
14685 /* Print an error message for invalid use of an incomplete type.
14686 VALUE is the expression that was used (or 0 if that isn't known)
14687 and TYPE is the type that was invalid. */
14690 incomplete_type_error (value
, type
)
14694 if (TREE_CODE (type
) == ERROR_MARK
)
14697 assert ("incomplete type?!?" == NULL
);
14700 /* Mark ARG for GC. */
14702 mark_binding_level (void *arg
)
14704 struct binding_level
*level
= *(struct binding_level
**) arg
;
14708 ggc_mark_tree (level
->names
);
14709 ggc_mark_tree (level
->blocks
);
14710 ggc_mark_tree (level
->this_block
);
14711 level
= level
->level_chain
;
14716 init_decl_processing ()
14718 static tree
*const tree_roots
[] = {
14719 ¤t_function_decl
,
14721 &ffecom_tree_fun_type_void
,
14722 &ffecom_integer_zero_node
,
14723 &ffecom_integer_one_node
,
14724 &ffecom_tree_subr_type
,
14725 &ffecom_tree_ptr_to_subr_type
,
14726 &ffecom_tree_blockdata_type
,
14727 &ffecom_tree_xargc_
,
14728 &ffecom_f2c_integer_type_node
,
14729 &ffecom_f2c_ptr_to_integer_type_node
,
14730 &ffecom_f2c_address_type_node
,
14731 &ffecom_f2c_real_type_node
,
14732 &ffecom_f2c_ptr_to_real_type_node
,
14733 &ffecom_f2c_doublereal_type_node
,
14734 &ffecom_f2c_complex_type_node
,
14735 &ffecom_f2c_doublecomplex_type_node
,
14736 &ffecom_f2c_longint_type_node
,
14737 &ffecom_f2c_logical_type_node
,
14738 &ffecom_f2c_flag_type_node
,
14739 &ffecom_f2c_ftnlen_type_node
,
14740 &ffecom_f2c_ftnlen_zero_node
,
14741 &ffecom_f2c_ftnlen_one_node
,
14742 &ffecom_f2c_ftnlen_two_node
,
14743 &ffecom_f2c_ptr_to_ftnlen_type_node
,
14744 &ffecom_f2c_ftnint_type_node
,
14745 &ffecom_f2c_ptr_to_ftnint_type_node
,
14746 &ffecom_outer_function_decl_
,
14747 &ffecom_previous_function_decl_
,
14748 &ffecom_which_entrypoint_decl_
,
14749 &ffecom_float_zero_
,
14750 &ffecom_float_half_
,
14751 &ffecom_double_zero_
,
14752 &ffecom_double_half_
,
14753 &ffecom_func_result_
,
14754 &ffecom_func_length_
,
14755 &ffecom_multi_type_node_
,
14756 &ffecom_multi_retval_
,
14764 /* Record our roots. */
14765 for (i
= 0; i
< sizeof(tree_roots
)/sizeof(tree_roots
[0]); i
++)
14766 ggc_add_tree_root (tree_roots
[i
], 1);
14767 ggc_add_tree_root (&ffecom_tree_type
[0][0],
14768 FFEINFO_basictype
*FFEINFO_kindtype
);
14769 ggc_add_tree_root (&ffecom_tree_fun_type
[0][0],
14770 FFEINFO_basictype
*FFEINFO_kindtype
);
14771 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type
[0][0],
14772 FFEINFO_basictype
*FFEINFO_kindtype
);
14773 ggc_add_tree_root (ffecom_gfrt_
, FFECOM_gfrt
);
14774 ggc_add_root (¤t_binding_level
, 1, sizeof current_binding_level
,
14775 mark_binding_level
);
14776 ggc_add_root (&free_binding_level
, 1, sizeof current_binding_level
,
14777 mark_binding_level
);
14778 ggc_add_root (&tracker_head
, 1, sizeof tracker_head
, mark_tracker_head
);
14784 init_parse (filename
)
14785 const char *filename
;
14787 /* Open input file. */
14788 if (filename
== 0 || !strcmp (filename
, "-"))
14791 filename
= "stdin";
14794 finput
= fopen (filename
, "r");
14796 pfatal_with_name (filename
);
14798 #ifdef IO_BUFFER_SIZE
14799 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14802 /* Make identifier nodes long enough for the language-specific slots. */
14803 set_identifier_size (sizeof (struct lang_identifier
));
14804 decl_printable_name
= lang_printable_name
;
14806 print_error_function
= lang_print_error_function
;
14818 /* Delete the node BLOCK from the current binding level.
14819 This is used for the block inside a stmt expr ({...})
14820 so that the block can be reinserted where appropriate. */
14823 delete_block (block
)
14827 if (current_binding_level
->blocks
== block
)
14828 current_binding_level
->blocks
= TREE_CHAIN (block
);
14829 for (t
= current_binding_level
->blocks
; t
;)
14831 if (TREE_CHAIN (t
) == block
)
14832 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14834 t
= TREE_CHAIN (t
);
14836 TREE_CHAIN (block
) = NULL
;
14837 /* Clear TREE_USED which is always set by poplevel.
14838 The flag is set again if insert_block is called. */
14839 TREE_USED (block
) = 0;
14843 insert_block (block
)
14846 TREE_USED (block
) = 1;
14847 current_binding_level
->blocks
14848 = chainon (current_binding_level
->blocks
, block
);
14852 lang_decode_option (argc
, argv
)
14856 return ffe_decode_option (argc
, argv
);
14859 /* used by print-tree.c */
14862 lang_print_xnode (file
, node
, indent
)
14872 ffe_terminate_0 ();
14874 if (ffe_is_ffedebug ())
14875 malloc_pool_display (malloc_pool_image ());
14884 /* Return the typed-based alias set for T, which may be an expression
14885 or a type. Return -1 if we don't do anything special. */
14888 lang_get_alias_set (t
)
14889 tree t ATTRIBUTE_UNUSED
;
14891 /* We do not wish to use alias-set based aliasing at all. Used in the
14892 extreme (every object with its own set, with equivalences recorded)
14893 it might be helpful, but there are problems when it comes to inlining.
14894 We get on ok with flag_argument_noalias, and alias-set aliasing does
14895 currently limit how stack slots can be reused, which is a lose. */
14900 lang_init_options ()
14902 /* Set default options for Fortran. */
14903 flag_move_all_movables
= 1;
14904 flag_reduce_all_givs
= 1;
14905 flag_argument_noalias
= 2;
14906 flag_errno_math
= 0;
14907 flag_complex_divide_method
= 1;
14913 /* If the file is output from cpp, it should contain a first line
14914 `# 1 "real-filename"', and the current design of gcc (toplev.c
14915 in particular and the way it sets up information relied on by
14916 INCLUDE) requires that we read this now, and store the
14917 "real-filename" info in master_input_filename. Ask the lexer
14918 to try doing this. */
14919 ffelex_hash_kludge (finput
);
14923 mark_addressable (exp
)
14926 register tree x
= exp
;
14928 switch (TREE_CODE (x
))
14931 case COMPONENT_REF
:
14933 x
= TREE_OPERAND (x
, 0);
14937 TREE_ADDRESSABLE (x
) = 1;
14944 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14945 && DECL_NONLOCAL (x
))
14947 if (TREE_PUBLIC (x
))
14949 assert ("address of global register var requested" == NULL
);
14952 assert ("address of register variable requested" == NULL
);
14954 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14956 if (TREE_PUBLIC (x
))
14958 assert ("address of global register var requested" == NULL
);
14961 assert ("address of register var requested" == NULL
);
14963 put_var_into_stack (x
);
14966 case FUNCTION_DECL
:
14967 TREE_ADDRESSABLE (x
) = 1;
14968 #if 0 /* poplevel deals with this now. */
14969 if (DECL_CONTEXT (x
) == 0)
14970 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14978 /* If DECL has a cleanup, build and return that cleanup here.
14979 This is a callback called by expand_expr. */
14982 maybe_build_cleanup (decl
)
14985 /* There are no cleanups in Fortran. */
14989 /* Exit a binding level.
14990 Pop the level off, and restore the state of the identifier-decl mappings
14991 that were in effect when this level was entered.
14993 If KEEP is nonzero, this level had explicit declarations, so
14994 and create a "block" (a BLOCK node) for the level
14995 to record its declarations and subblocks for symbol table output.
14997 If FUNCTIONBODY is nonzero, this level is the body of a function,
14998 so create a block as if KEEP were set and also clear out all
15001 If REVERSE is nonzero, reverse the order of decls before putting
15002 them into the BLOCK. */
15005 poplevel (keep
, reverse
, functionbody
)
15010 register tree link
;
15011 /* The chain of decls was accumulated in reverse order.
15012 Put it into forward order, just for cleanliness. */
15014 tree subblocks
= current_binding_level
->blocks
;
15017 int block_previously_created
;
15019 /* Get the decls in the order they were written.
15020 Usually current_binding_level->names is in reverse order.
15021 But parameter decls were previously put in forward order. */
15024 current_binding_level
->names
15025 = decls
= nreverse (current_binding_level
->names
);
15027 decls
= current_binding_level
->names
;
15029 /* Output any nested inline functions within this block
15030 if they weren't already output. */
15032 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
15033 if (TREE_CODE (decl
) == FUNCTION_DECL
15034 && ! TREE_ASM_WRITTEN (decl
)
15035 && DECL_INITIAL (decl
) != 0
15036 && TREE_ADDRESSABLE (decl
))
15038 /* If this decl was copied from a file-scope decl
15039 on account of a block-scope extern decl,
15040 propagate TREE_ADDRESSABLE to the file-scope decl.
15042 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15043 true, since then the decl goes through save_for_inline_copying. */
15044 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
15045 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
15046 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
15047 else if (DECL_SAVED_INSNS (decl
) != 0)
15049 push_function_context ();
15050 output_inline_function (decl
);
15051 pop_function_context ();
15055 /* If there were any declarations or structure tags in that level,
15056 or if this level is a function body,
15057 create a BLOCK to record them for the life of this function. */
15060 block_previously_created
= (current_binding_level
->this_block
!= 0);
15061 if (block_previously_created
)
15062 block
= current_binding_level
->this_block
;
15063 else if (keep
|| functionbody
)
15064 block
= make_node (BLOCK
);
15067 BLOCK_VARS (block
) = decls
;
15068 BLOCK_SUBBLOCKS (block
) = subblocks
;
15071 /* In each subblock, record that this is its superior. */
15073 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
15074 BLOCK_SUPERCONTEXT (link
) = block
;
15076 /* Clear out the meanings of the local variables of this level. */
15078 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
15080 if (DECL_NAME (link
) != 0)
15082 /* If the ident. was used or addressed via a local extern decl,
15083 don't forget that fact. */
15084 if (DECL_EXTERNAL (link
))
15086 if (TREE_USED (link
))
15087 TREE_USED (DECL_NAME (link
)) = 1;
15088 if (TREE_ADDRESSABLE (link
))
15089 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
15091 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
15095 /* If the level being exited is the top level of a function,
15096 check over all the labels, and clear out the current
15097 (function local) meanings of their names. */
15101 /* If this is the top level block of a function,
15102 the vars are the function's parameters.
15103 Don't leave them in the BLOCK because they are
15104 found in the FUNCTION_DECL instead. */
15106 BLOCK_VARS (block
) = 0;
15109 /* Pop the current level, and free the structure for reuse. */
15112 register struct binding_level
*level
= current_binding_level
;
15113 current_binding_level
= current_binding_level
->level_chain
;
15115 level
->level_chain
= free_binding_level
;
15116 free_binding_level
= level
;
15119 /* Dispose of the block that we just made inside some higher level. */
15121 && current_function_decl
!= error_mark_node
)
15122 DECL_INITIAL (current_function_decl
) = block
;
15125 if (!block_previously_created
)
15126 current_binding_level
->blocks
15127 = chainon (current_binding_level
->blocks
, block
);
15129 /* If we did not make a block for the level just exited,
15130 any blocks made for inner levels
15131 (since they cannot be recorded as subblocks in that level)
15132 must be carried forward so they will later become subblocks
15133 of something else. */
15134 else if (subblocks
)
15135 current_binding_level
->blocks
15136 = chainon (current_binding_level
->blocks
, subblocks
);
15139 TREE_USED (block
) = 1;
15144 print_lang_decl (file
, node
, indent
)
15152 print_lang_identifier (file
, node
, indent
)
15157 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
15158 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
15162 print_lang_statistics ()
15167 print_lang_type (file
, node
, indent
)
15174 /* Record a decl-node X as belonging to the current lexical scope.
15175 Check for errors (such as an incompatible declaration for the same
15176 name already seen in the same scope).
15178 Returns either X or an old decl for the same name.
15179 If an old decl is returned, it may have been smashed
15180 to agree with what X says. */
15187 register tree name
= DECL_NAME (x
);
15188 register struct binding_level
*b
= current_binding_level
;
15190 if ((TREE_CODE (x
) == FUNCTION_DECL
)
15191 && (DECL_INITIAL (x
) == 0)
15192 && DECL_EXTERNAL (x
))
15193 DECL_CONTEXT (x
) = NULL_TREE
;
15195 DECL_CONTEXT (x
) = current_function_decl
;
15199 if (IDENTIFIER_INVENTED (name
))
15202 DECL_ARTIFICIAL (x
) = 1;
15204 DECL_IN_SYSTEM_HEADER (x
) = 1;
15207 t
= lookup_name_current_level (name
);
15209 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
15211 /* Don't push non-parms onto list for parms until we understand
15212 why we're doing this and whether it works. */
15214 assert ((b
== global_binding_level
)
15215 || !ffecom_transform_only_dummies_
15216 || TREE_CODE (x
) == PARM_DECL
);
15218 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15221 /* If we are processing a typedef statement, generate a whole new
15222 ..._TYPE node (which will be just an variant of the existing
15223 ..._TYPE node with identical properties) and then install the
15224 TYPE_DECL node generated to represent the typedef name as the
15225 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15227 The whole point here is to end up with a situation where each and every
15228 ..._TYPE node the compiler creates will be uniquely associated with
15229 AT MOST one node representing a typedef name. This way, even though
15230 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15231 (i.e. "typedef name") nodes very early on, later parts of the
15232 compiler can always do the reverse translation and get back the
15233 corresponding typedef name. For example, given:
15235 typedef struct S MY_TYPE; MY_TYPE object;
15237 Later parts of the compiler might only know that `object' was of type
15238 `struct S' if it were not for code just below. With this code
15239 however, later parts of the compiler see something like:
15241 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15243 And they can then deduce (from the node for type struct S') that the
15244 original object declaration was:
15248 Being able to do this is important for proper support of protoize, and
15249 also for generating precise symbolic debugging information which
15250 takes full account of the programmer's (typedef) vocabulary.
15252 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15253 TYPE_DECL node that we are now processing really represents a
15254 standard built-in type.
15256 Since all standard types are effectively declared at line zero in the
15257 source file, we can easily check to see if we are working on a
15258 standard type by checking the current value of lineno. */
15260 if (TREE_CODE (x
) == TYPE_DECL
)
15262 if (DECL_SOURCE_LINE (x
) == 0)
15264 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15265 TYPE_NAME (TREE_TYPE (x
)) = x
;
15267 else if (TREE_TYPE (x
) != error_mark_node
)
15269 tree tt
= TREE_TYPE (x
);
15271 tt
= build_type_copy (tt
);
15272 TYPE_NAME (tt
) = x
;
15273 TREE_TYPE (x
) = tt
;
15277 /* This name is new in its binding level. Install the new declaration
15279 if (b
== global_binding_level
)
15280 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15282 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15285 /* Put decls on list in reverse order. We will reverse them later if
15287 TREE_CHAIN (x
) = b
->names
;
15293 /* Nonzero if the current level needs to have a BLOCK made. */
15300 for (decl
= current_binding_level
->names
;
15302 decl
= TREE_CHAIN (decl
))
15304 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
15305 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
15306 /* Currently, there aren't supposed to be non-artificial names
15307 at other than the top block for a function -- they're
15308 believed to always be temps. But it's wise to check anyway. */
15314 /* Enter a new binding level.
15315 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15316 not for that of tags. */
15319 pushlevel (tag_transparent
)
15320 int tag_transparent
;
15322 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15324 assert (! tag_transparent
);
15326 if (current_binding_level
== global_binding_level
)
15331 /* Reuse or create a struct for this binding level. */
15333 if (free_binding_level
)
15335 newlevel
= free_binding_level
;
15336 free_binding_level
= free_binding_level
->level_chain
;
15340 newlevel
= make_binding_level ();
15343 /* Add this level to the front of the chain (stack) of levels that
15346 *newlevel
= clear_binding_level
;
15347 newlevel
->level_chain
= current_binding_level
;
15348 current_binding_level
= newlevel
;
15351 /* Set the BLOCK node for the innermost scope
15352 (the one we are currently in). */
15356 register tree block
;
15358 current_binding_level
->this_block
= block
;
15361 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15363 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15366 set_yydebug (value
)
15370 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15374 signed_or_unsigned_type (unsignedp
, type
)
15380 if (! INTEGRAL_TYPE_P (type
))
15382 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15383 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15384 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15385 return unsignedp
? unsigned_type_node
: integer_type_node
;
15386 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15387 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15388 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15389 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15390 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15391 return (unsignedp
? long_long_unsigned_type_node
15392 : long_long_integer_type_node
);
15394 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15395 if (type2
== NULL_TREE
)
15405 tree type1
= TYPE_MAIN_VARIANT (type
);
15406 ffeinfoKindtype kt
;
15409 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15410 return signed_char_type_node
;
15411 if (type1
== unsigned_type_node
)
15412 return integer_type_node
;
15413 if (type1
== short_unsigned_type_node
)
15414 return short_integer_type_node
;
15415 if (type1
== long_unsigned_type_node
)
15416 return long_integer_type_node
;
15417 if (type1
== long_long_unsigned_type_node
)
15418 return long_long_integer_type_node
;
15419 #if 0 /* gcc/c-* files only */
15420 if (type1
== unsigned_intDI_type_node
)
15421 return intDI_type_node
;
15422 if (type1
== unsigned_intSI_type_node
)
15423 return intSI_type_node
;
15424 if (type1
== unsigned_intHI_type_node
)
15425 return intHI_type_node
;
15426 if (type1
== unsigned_intQI_type_node
)
15427 return intQI_type_node
;
15430 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15431 if (type2
!= NULL_TREE
)
15434 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15436 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15438 if (type1
== type2
)
15439 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15445 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15446 or validate its data type for an `if' or `while' statement or ?..: exp.
15448 This preparation consists of taking the ordinary
15449 representation of an expression expr and producing a valid tree
15450 boolean expression describing whether expr is nonzero. We could
15451 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15452 but we optimize comparisons, &&, ||, and !.
15454 The resulting type should always be `integer_type_node'. */
15457 truthvalue_conversion (expr
)
15460 if (TREE_CODE (expr
) == ERROR_MARK
)
15463 #if 0 /* This appears to be wrong for C++. */
15464 /* These really should return error_mark_node after 2.4 is stable.
15465 But not all callers handle ERROR_MARK properly. */
15466 switch (TREE_CODE (TREE_TYPE (expr
)))
15469 error ("struct type value used where scalar is required");
15470 return integer_zero_node
;
15473 error ("union type value used where scalar is required");
15474 return integer_zero_node
;
15477 error ("array type value used where scalar is required");
15478 return integer_zero_node
;
15485 switch (TREE_CODE (expr
))
15487 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15488 or comparison expressions as truth values at this level. */
15490 case COMPONENT_REF
:
15491 /* A one-bit unsigned bit-field is already acceptable. */
15492 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15493 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15499 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15500 or comparison expressions as truth values at this level. */
15502 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15503 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15505 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15506 case TRUTH_ANDIF_EXPR
:
15507 case TRUTH_ORIF_EXPR
:
15508 case TRUTH_AND_EXPR
:
15509 case TRUTH_OR_EXPR
:
15510 case TRUTH_XOR_EXPR
:
15511 TREE_TYPE (expr
) = integer_type_node
;
15518 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15521 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15524 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15525 return build (COMPOUND_EXPR
, integer_type_node
,
15526 TREE_OPERAND (expr
, 0), integer_one_node
);
15528 return integer_one_node
;
15531 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15532 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15534 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15535 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15541 /* These don't change whether an object is non-zero or zero. */
15542 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15546 /* These don't change whether an object is zero or non-zero, but
15547 we can't ignore them if their second arg has side-effects. */
15548 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15549 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15550 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15552 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15555 /* Distribute the conversion into the arms of a COND_EXPR. */
15556 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15557 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15558 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15561 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15562 since that affects how `default_conversion' will behave. */
15563 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15564 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15566 /* fall through... */
15568 /* If this is widening the argument, we can ignore it. */
15569 if (TYPE_PRECISION (TREE_TYPE (expr
))
15570 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15571 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15575 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15577 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15578 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15580 /* fall through... */
15582 /* This and MINUS_EXPR can be changed into a comparison of the
15584 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15585 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15586 return ffecom_2 (NE_EXPR
, integer_type_node
,
15587 TREE_OPERAND (expr
, 0),
15588 TREE_OPERAND (expr
, 1));
15589 return ffecom_2 (NE_EXPR
, integer_type_node
,
15590 TREE_OPERAND (expr
, 0),
15591 fold (build1 (NOP_EXPR
,
15592 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15593 TREE_OPERAND (expr
, 1))));
15596 if (integer_onep (TREE_OPERAND (expr
, 1)))
15601 #if 0 /* No such thing in Fortran. */
15602 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15603 warning ("suggest parentheses around assignment used as truth value");
15611 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15613 ((TREE_SIDE_EFFECTS (expr
)
15614 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15616 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15617 TREE_TYPE (TREE_TYPE (expr
)),
15619 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15620 TREE_TYPE (TREE_TYPE (expr
)),
15623 return ffecom_2 (NE_EXPR
, integer_type_node
,
15625 convert (TREE_TYPE (expr
), integer_zero_node
));
15629 type_for_mode (mode
, unsignedp
)
15630 enum machine_mode mode
;
15637 if (mode
== TYPE_MODE (integer_type_node
))
15638 return unsignedp
? unsigned_type_node
: integer_type_node
;
15640 if (mode
== TYPE_MODE (signed_char_type_node
))
15641 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15643 if (mode
== TYPE_MODE (short_integer_type_node
))
15644 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15646 if (mode
== TYPE_MODE (long_integer_type_node
))
15647 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15649 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15650 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15652 #if HOST_BITS_PER_WIDE_INT >= 64
15653 if (mode
== TYPE_MODE (intTI_type_node
))
15654 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
15657 if (mode
== TYPE_MODE (float_type_node
))
15658 return float_type_node
;
15660 if (mode
== TYPE_MODE (double_type_node
))
15661 return double_type_node
;
15663 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15664 return build_pointer_type (char_type_node
);
15666 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15667 return build_pointer_type (integer_type_node
);
15669 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15670 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15672 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15673 && (mode
== TYPE_MODE (t
)))
15675 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15676 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15686 type_for_size (bits
, unsignedp
)
15690 ffeinfoKindtype kt
;
15693 if (bits
== TYPE_PRECISION (integer_type_node
))
15694 return unsignedp
? unsigned_type_node
: integer_type_node
;
15696 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15697 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15699 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15700 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15702 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15703 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15705 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15706 return (unsignedp
? long_long_unsigned_type_node
15707 : long_long_integer_type_node
);
15709 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15711 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15713 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15714 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15722 unsigned_type (type
)
15725 tree type1
= TYPE_MAIN_VARIANT (type
);
15726 ffeinfoKindtype kt
;
15729 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15730 return unsigned_char_type_node
;
15731 if (type1
== integer_type_node
)
15732 return unsigned_type_node
;
15733 if (type1
== short_integer_type_node
)
15734 return short_unsigned_type_node
;
15735 if (type1
== long_integer_type_node
)
15736 return long_unsigned_type_node
;
15737 if (type1
== long_long_integer_type_node
)
15738 return long_long_unsigned_type_node
;
15739 #if 0 /* gcc/c-* files only */
15740 if (type1
== intDI_type_node
)
15741 return unsigned_intDI_type_node
;
15742 if (type1
== intSI_type_node
)
15743 return unsigned_intSI_type_node
;
15744 if (type1
== intHI_type_node
)
15745 return unsigned_intHI_type_node
;
15746 if (type1
== intQI_type_node
)
15747 return unsigned_intQI_type_node
;
15750 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15751 if (type2
!= NULL_TREE
)
15754 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15756 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15758 if (type1
== type2
)
15759 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15765 /* Callback routines for garbage collection. */
15771 union tree_node
*t ATTRIBUTE_UNUSED
;
15773 if (TREE_CODE (t
) == IDENTIFIER_NODE
)
15775 struct lang_identifier
*i
= (struct lang_identifier
*) t
;
15776 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i
));
15777 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i
));
15778 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i
));
15780 else if (TYPE_P (t
) && TYPE_LANG_SPECIFIC (t
))
15781 ggc_mark (TYPE_LANG_SPECIFIC (t
));
15785 lang_mark_false_label_stack (l
)
15786 struct label_node
*l
;
15788 /* Fortran doesn't use false_label_stack. It better be NULL. */
15793 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15795 #if FFECOM_GCC_INCLUDE
15797 /* From gcc/cccp.c, the code to handle -I. */
15799 /* Skip leading "./" from a directory name.
15800 This may yield the empty string, which represents the current directory. */
15802 static const char *
15803 skip_redundant_dir_prefix (const char *dir
)
15805 while (dir
[0] == '.' && dir
[1] == '/')
15806 for (dir
+= 2; *dir
== '/'; dir
++)
15808 if (dir
[0] == '.' && !dir
[1])
15813 /* The file_name_map structure holds a mapping of file names for a
15814 particular directory. This mapping is read from the file named
15815 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15816 map filenames on a file system with severe filename restrictions,
15817 such as DOS. The format of the file name map file is just a series
15818 of lines with two tokens on each line. The first token is the name
15819 to map, and the second token is the actual name to use. */
15821 struct file_name_map
15823 struct file_name_map
*map_next
;
15828 #define FILE_NAME_MAP_FILE "header.gcc"
15830 /* Current maximum length of directory names in the search path
15831 for include files. (Altered as we get more of them.) */
15833 static int max_include_len
= 0;
15835 struct file_name_list
15837 struct file_name_list
*next
;
15839 /* Mapping of file names for this directory. */
15840 struct file_name_map
*name_map
;
15841 /* Non-zero if name_map is valid. */
15845 static struct file_name_list
*include
= NULL
; /* First dir to search */
15846 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15848 /* I/O buffer structure.
15849 The `fname' field is nonzero for source files and #include files
15850 and for the dummy text used for -D and -U.
15851 It is zero for rescanning results of macro expansion
15852 and for expanding macro arguments. */
15853 #define INPUT_STACK_MAX 400
15854 static struct file_buf
{
15856 /* Filename specified with #line command. */
15857 const char *nominal_fname
;
15858 /* Record where in the search path this file was found.
15859 For #include_next. */
15860 struct file_name_list
*dir
;
15862 ffewhereColumn column
;
15863 } instack
[INPUT_STACK_MAX
];
15865 static int last_error_tick
= 0; /* Incremented each time we print it. */
15866 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15868 /* Current nesting level of input sources.
15869 `instack[indepth]' is the level currently being read. */
15870 static int indepth
= -1;
15872 typedef struct file_buf FILE_BUF
;
15874 typedef unsigned char U_CHAR
;
15876 /* table to tell if char can be part of a C identifier. */
15877 U_CHAR is_idchar
[256];
15878 /* table to tell if char can be first char of a c identifier. */
15879 U_CHAR is_idstart
[256];
15880 /* table to tell if c is horizontal space. */
15881 U_CHAR is_hor_space
[256];
15882 /* table to tell if c is horizontal or vertical space. */
15883 static U_CHAR is_space
[256];
15885 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15886 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15888 /* Nonzero means -I- has been seen,
15889 so don't look for #include "foo" the source-file directory. */
15890 static int ignore_srcdir
;
15892 #ifndef INCLUDE_LEN_FUDGE
15893 #define INCLUDE_LEN_FUDGE 0
15896 static void append_include_chain (struct file_name_list
*first
,
15897 struct file_name_list
*last
);
15898 static FILE *open_include_file (char *filename
,
15899 struct file_name_list
*searchptr
);
15900 static void print_containing_files (ffebadSeverity sev
);
15901 static const char *skip_redundant_dir_prefix (const char *);
15902 static char *read_filename_string (int ch
, FILE *f
);
15903 static struct file_name_map
*read_name_map (const char *dirname
);
15905 /* Append a chain of `struct file_name_list's
15906 to the end of the main include chain.
15907 FIRST is the beginning of the chain to append, and LAST is the end. */
15910 append_include_chain (first
, last
)
15911 struct file_name_list
*first
, *last
;
15913 struct file_name_list
*dir
;
15915 if (!first
|| !last
)
15921 last_include
->next
= first
;
15923 for (dir
= first
; ; dir
= dir
->next
) {
15924 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15925 if (len
> max_include_len
)
15926 max_include_len
= len
;
15932 last_include
= last
;
15935 /* Try to open include file FILENAME. SEARCHPTR is the directory
15936 being tried from the include file search path. This function maps
15937 filenames on file systems based on information read by
15941 open_include_file (filename
, searchptr
)
15943 struct file_name_list
*searchptr
;
15945 register struct file_name_map
*map
;
15946 register char *from
;
15949 if (searchptr
&& ! searchptr
->got_name_map
)
15951 searchptr
->name_map
= read_name_map (searchptr
->fname
15952 ? searchptr
->fname
: ".");
15953 searchptr
->got_name_map
= 1;
15956 /* First check the mapping for the directory we are using. */
15957 if (searchptr
&& searchptr
->name_map
)
15960 if (searchptr
->fname
)
15961 from
+= strlen (searchptr
->fname
) + 1;
15962 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15964 if (! strcmp (map
->map_from
, from
))
15966 /* Found a match. */
15967 return fopen (map
->map_to
, "r");
15972 /* Try to find a mapping file for the particular directory we are
15973 looking in. Thus #include <sys/types.h> will look up sys/types.h
15974 in /usr/include/header.gcc and look up types.h in
15975 /usr/include/sys/header.gcc. */
15976 p
= rindex (filename
, '/');
15977 #ifdef DIR_SEPARATOR
15978 if (! p
) p
= rindex (filename
, DIR_SEPARATOR
);
15980 char *tmp
= rindex (filename
, DIR_SEPARATOR
);
15981 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15987 && searchptr
->fname
15988 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15989 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15991 /* FILENAME is in SEARCHPTR, which we've already checked. */
15992 return fopen (filename
, "r");
15998 map
= read_name_map (".");
16002 dir
= (char *) xmalloc (p
- filename
+ 1);
16003 memcpy (dir
, filename
, p
- filename
);
16004 dir
[p
- filename
] = '\0';
16006 map
= read_name_map (dir
);
16009 for (; map
; map
= map
->map_next
)
16010 if (! strcmp (map
->map_from
, from
))
16011 return fopen (map
->map_to
, "r");
16013 return fopen (filename
, "r");
16016 /* Print the file names and line numbers of the #include
16017 commands which led to the current file. */
16020 print_containing_files (ffebadSeverity sev
)
16022 FILE_BUF
*ip
= NULL
;
16028 /* If stack of files hasn't changed since we last printed
16029 this info, don't repeat it. */
16030 if (last_error_tick
== input_file_stack_tick
)
16033 for (i
= indepth
; i
>= 0; i
--)
16034 if (instack
[i
].fname
!= NULL
) {
16039 /* Give up if we don't find a source file. */
16043 /* Find the other, outer source files. */
16044 for (i
--; i
>= 0; i
--)
16045 if (instack
[i
].fname
!= NULL
)
16051 str1
= "In file included";
16063 ffebad_start_msg ("%A from %B at %0%C", sev
);
16064 ffebad_here (0, ip
->line
, ip
->column
);
16065 ffebad_string (str1
);
16066 ffebad_string (ip
->nominal_fname
);
16067 ffebad_string (str2
);
16071 /* Record we have printed the status as of this time. */
16072 last_error_tick
= input_file_stack_tick
;
16075 /* Read a space delimited string of unlimited length from a stdio
16079 read_filename_string (ch
, f
)
16087 set
= alloc
= xmalloc (len
+ 1);
16088 if (! is_space
[ch
])
16091 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
16093 if (set
- alloc
== len
)
16096 alloc
= xrealloc (alloc
, len
+ 1);
16097 set
= alloc
+ len
/ 2;
16107 /* Read the file name map file for DIRNAME. */
16109 static struct file_name_map
*
16110 read_name_map (dirname
)
16111 const char *dirname
;
16113 /* This structure holds a linked list of file name maps, one per
16115 struct file_name_map_list
16117 struct file_name_map_list
*map_list_next
;
16118 char *map_list_name
;
16119 struct file_name_map
*map_list_map
;
16121 static struct file_name_map_list
*map_list
;
16122 register struct file_name_map_list
*map_list_ptr
;
16126 int separator_needed
;
16128 dirname
= skip_redundant_dir_prefix (dirname
);
16130 for (map_list_ptr
= map_list
; map_list_ptr
;
16131 map_list_ptr
= map_list_ptr
->map_list_next
)
16132 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
16133 return map_list_ptr
->map_list_map
;
16135 map_list_ptr
= ((struct file_name_map_list
*)
16136 xmalloc (sizeof (struct file_name_map_list
)));
16137 map_list_ptr
->map_list_name
= xstrdup (dirname
);
16138 map_list_ptr
->map_list_map
= NULL
;
16140 dirlen
= strlen (dirname
);
16141 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
16142 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
16143 strcpy (name
, dirname
);
16144 name
[dirlen
] = '/';
16145 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
16146 f
= fopen (name
, "r");
16149 map_list_ptr
->map_list_map
= NULL
;
16154 while ((ch
= getc (f
)) != EOF
)
16157 struct file_name_map
*ptr
;
16161 from
= read_filename_string (ch
, f
);
16162 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
16164 to
= read_filename_string (ch
, f
);
16166 ptr
= ((struct file_name_map
*)
16167 xmalloc (sizeof (struct file_name_map
)));
16168 ptr
->map_from
= from
;
16170 /* Make the real filename absolute. */
16175 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
16176 strcpy (ptr
->map_to
, dirname
);
16177 ptr
->map_to
[dirlen
] = '/';
16178 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
16182 ptr
->map_next
= map_list_ptr
->map_list_map
;
16183 map_list_ptr
->map_list_map
= ptr
;
16185 while ((ch
= getc (f
)) != '\n')
16192 map_list_ptr
->map_list_next
= map_list
;
16193 map_list
= map_list_ptr
;
16195 return map_list_ptr
->map_list_map
;
16199 ffecom_file_ (const char *name
)
16203 /* Do partial setup of input buffer for the sake of generating
16204 early #line directives (when -g is in effect). */
16206 fp
= &instack
[++indepth
];
16207 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16210 fp
->nominal_fname
= fp
->fname
= name
;
16213 /* Initialize syntactic classifications of characters. */
16216 ffecom_initialize_char_syntax_ ()
16221 * Set up is_idchar and is_idstart tables. These should be
16222 * faster than saying (is_alpha (c) || c == '_'), etc.
16223 * Set up these things before calling any routines tthat
16226 for (i
= 'a'; i
<= 'z'; i
++) {
16227 is_idchar
[i
- 'a' + 'A'] = 1;
16229 is_idstart
[i
- 'a' + 'A'] = 1;
16232 for (i
= '0'; i
<= '9'; i
++)
16234 is_idchar
['_'] = 1;
16235 is_idstart
['_'] = 1;
16237 /* horizontal space table */
16238 is_hor_space
[' '] = 1;
16239 is_hor_space
['\t'] = 1;
16240 is_hor_space
['\v'] = 1;
16241 is_hor_space
['\f'] = 1;
16242 is_hor_space
['\r'] = 1;
16245 is_space
['\t'] = 1;
16246 is_space
['\v'] = 1;
16247 is_space
['\f'] = 1;
16248 is_space
['\n'] = 1;
16249 is_space
['\r'] = 1;
16253 ffecom_close_include_ (FILE *f
)
16258 input_file_stack_tick
++;
16260 ffewhere_line_kill (instack
[indepth
].line
);
16261 ffewhere_column_kill (instack
[indepth
].column
);
16265 ffecom_decode_include_option_ (char *spec
)
16267 struct file_name_list
*dirtmp
;
16269 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16273 dirtmp
= (struct file_name_list
*)
16274 xmalloc (sizeof (struct file_name_list
));
16275 dirtmp
->next
= 0; /* New one goes on the end */
16277 dirtmp
->fname
= spec
;
16279 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16280 dirtmp
->got_name_map
= 0;
16281 append_include_chain (dirtmp
, dirtmp
);
16286 /* Open INCLUDEd file. */
16289 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16292 size_t flen
= strlen (fbeg
);
16293 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16294 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16295 struct file_name_list
*searchptr
= 0;
16296 char *fname
; /* Dynamically allocated fname buffer */
16303 dsp
[0].fname
= NULL
;
16305 /* If -I- was specified, don't search current dir, only spec'd ones. */
16306 if (!ignore_srcdir
)
16308 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16314 if ((nam
= fp
->nominal_fname
) != NULL
)
16316 /* Found a named file. Figure out dir of the file,
16317 and put it in front of the search list. */
16318 dsp
[0].next
= search_start
;
16319 search_start
= dsp
;
16321 ep
= rindex (nam
, '/');
16322 #ifdef DIR_SEPARATOR
16323 if (ep
== NULL
) ep
= rindex (nam
, DIR_SEPARATOR
);
16325 char *tmp
= rindex (nam
, DIR_SEPARATOR
);
16326 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16330 ep
= rindex (nam
, ']');
16331 if (ep
== NULL
) ep
= rindex (nam
, '>');
16332 if (ep
== NULL
) ep
= rindex (nam
, ':');
16333 if (ep
!= NULL
) ep
++;
16338 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16339 strncpy (dsp
[0].fname
, nam
, n
);
16340 dsp
[0].fname
[n
] = '\0';
16341 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16342 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16345 dsp
[0].fname
= NULL
; /* Current directory */
16346 dsp
[0].got_name_map
= 0;
16352 /* Allocate this permanently, because it gets stored in the definitions
16354 fname
= xmalloc (max_include_len
+ flen
+ 4);
16355 /* + 2 above for slash and terminating null. */
16356 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16359 /* If specified file name is absolute, just open it. */
16362 #ifdef DIR_SEPARATOR
16363 || *fbeg
== DIR_SEPARATOR
16367 strncpy (fname
, (char *) fbeg
, flen
);
16369 f
= open_include_file (fname
, NULL_PTR
);
16375 /* Search directory path, trying to open the file.
16376 Copy each filename tried into FNAME. */
16378 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16380 if (searchptr
->fname
)
16382 /* The empty string in a search path is ignored.
16383 This makes it possible to turn off entirely
16384 a standard piece of the list. */
16385 if (searchptr
->fname
[0] == 0)
16387 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16388 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16389 strcat (fname
, "/");
16390 fname
[strlen (fname
) + flen
] = 0;
16395 strncat (fname
, fbeg
, flen
);
16397 /* Change this 1/2 Unix 1/2 VMS file specification into a
16398 full VMS file specification */
16399 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16401 /* Fix up the filename */
16402 hack_vms_include_specification (fname
);
16406 /* This is a normal VMS filespec, so use it unchanged. */
16407 strncpy (fname
, (char *) fbeg
, flen
);
16409 #if 0 /* Not for g77. */
16410 /* if it's '#include filename', add the missing .h */
16411 if (index (fname
, '.') == NULL
)
16412 strcat (fname
, ".h");
16416 f
= open_include_file (fname
, searchptr
);
16418 if (f
== NULL
&& errno
== EACCES
)
16420 print_containing_files (FFEBAD_severityWARNING
);
16421 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16422 FFEBAD_severityWARNING
);
16423 ffebad_string (fname
);
16424 ffebad_here (0, l
, c
);
16435 /* A file that was not found. */
16437 strncpy (fname
, (char *) fbeg
, flen
);
16439 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16440 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16441 ffebad_here (0, l
, c
);
16442 ffebad_string (fname
);
16446 if (dsp
[0].fname
!= NULL
)
16447 free (dsp
[0].fname
);
16452 if (indepth
>= (INPUT_STACK_MAX
- 1))
16454 print_containing_files (FFEBAD_severityFATAL
);
16455 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16456 FFEBAD_severityFATAL
);
16457 ffebad_string (fname
);
16458 ffebad_here (0, l
, c
);
16463 instack
[indepth
].line
= ffewhere_line_use (l
);
16464 instack
[indepth
].column
= ffewhere_column_use (c
);
16466 fp
= &instack
[indepth
+ 1];
16467 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16468 fp
->nominal_fname
= fp
->fname
= fname
;
16469 fp
->dir
= searchptr
;
16472 input_file_stack_tick
++;
16476 #endif /* FFECOM_GCC_INCLUDE */
16478 /**INDENT* (Do not reformat this comment even with -fca option.)
16479 Data-gathering files: Given the source file listed below, compiled with
16480 f2c I obtained the output file listed after that, and from the output
16481 file I derived the above code.
16483 -------- (begin input file to f2c)
16489 double precision D1,D2
16491 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16518 c FFEINTRIN_impACOS
16519 call fooR(ACOS(R1))
16520 c FFEINTRIN_impAIMAG
16521 call fooR(AIMAG(C1))
16522 c FFEINTRIN_impAINT
16523 call fooR(AINT(R1))
16524 c FFEINTRIN_impALOG
16525 call fooR(ALOG(R1))
16526 c FFEINTRIN_impALOG10
16527 call fooR(ALOG10(R1))
16528 c FFEINTRIN_impAMAX0
16529 call fooR(AMAX0(I1,I2))
16530 c FFEINTRIN_impAMAX1
16531 call fooR(AMAX1(R1,R2))
16532 c FFEINTRIN_impAMIN0
16533 call fooR(AMIN0(I1,I2))
16534 c FFEINTRIN_impAMIN1
16535 call fooR(AMIN1(R1,R2))
16536 c FFEINTRIN_impAMOD
16537 call fooR(AMOD(R1,R2))
16538 c FFEINTRIN_impANINT
16539 call fooR(ANINT(R1))
16540 c FFEINTRIN_impASIN
16541 call fooR(ASIN(R1))
16542 c FFEINTRIN_impATAN
16543 call fooR(ATAN(R1))
16544 c FFEINTRIN_impATAN2
16545 call fooR(ATAN2(R1,R2))
16546 c FFEINTRIN_impCABS
16547 call fooR(CABS(C1))
16548 c FFEINTRIN_impCCOS
16549 call fooC(CCOS(C1))
16550 c FFEINTRIN_impCEXP
16551 call fooC(CEXP(C1))
16552 c FFEINTRIN_impCHAR
16553 call fooA(CHAR(I1))
16554 c FFEINTRIN_impCLOG
16555 call fooC(CLOG(C1))
16556 c FFEINTRIN_impCONJG
16557 call fooC(CONJG(C1))
16560 c FFEINTRIN_impCOSH
16561 call fooR(COSH(R1))
16562 c FFEINTRIN_impCSIN
16563 call fooC(CSIN(C1))
16564 c FFEINTRIN_impCSQRT
16565 call fooC(CSQRT(C1))
16566 c FFEINTRIN_impDABS
16567 call fooD(DABS(D1))
16568 c FFEINTRIN_impDACOS
16569 call fooD(DACOS(D1))
16570 c FFEINTRIN_impDASIN
16571 call fooD(DASIN(D1))
16572 c FFEINTRIN_impDATAN
16573 call fooD(DATAN(D1))
16574 c FFEINTRIN_impDATAN2
16575 call fooD(DATAN2(D1,D2))
16576 c FFEINTRIN_impDCOS
16577 call fooD(DCOS(D1))
16578 c FFEINTRIN_impDCOSH
16579 call fooD(DCOSH(D1))
16580 c FFEINTRIN_impDDIM
16581 call fooD(DDIM(D1,D2))
16582 c FFEINTRIN_impDEXP
16583 call fooD(DEXP(D1))
16585 call fooR(DIM(R1,R2))
16586 c FFEINTRIN_impDINT
16587 call fooD(DINT(D1))
16588 c FFEINTRIN_impDLOG
16589 call fooD(DLOG(D1))
16590 c FFEINTRIN_impDLOG10
16591 call fooD(DLOG10(D1))
16592 c FFEINTRIN_impDMAX1
16593 call fooD(DMAX1(D1,D2))
16594 c FFEINTRIN_impDMIN1
16595 call fooD(DMIN1(D1,D2))
16596 c FFEINTRIN_impDMOD
16597 call fooD(DMOD(D1,D2))
16598 c FFEINTRIN_impDNINT
16599 call fooD(DNINT(D1))
16600 c FFEINTRIN_impDPROD
16601 call fooD(DPROD(R1,R2))
16602 c FFEINTRIN_impDSIGN
16603 call fooD(DSIGN(D1,D2))
16604 c FFEINTRIN_impDSIN
16605 call fooD(DSIN(D1))
16606 c FFEINTRIN_impDSINH
16607 call fooD(DSINH(D1))
16608 c FFEINTRIN_impDSQRT
16609 call fooD(DSQRT(D1))
16610 c FFEINTRIN_impDTAN
16611 call fooD(DTAN(D1))
16612 c FFEINTRIN_impDTANH
16613 call fooD(DTANH(D1))
16616 c FFEINTRIN_impIABS
16617 call fooI(IABS(I1))
16618 c FFEINTRIN_impICHAR
16619 call fooI(ICHAR(A1))
16620 c FFEINTRIN_impIDIM
16621 call fooI(IDIM(I1,I2))
16622 c FFEINTRIN_impIDNINT
16623 call fooI(IDNINT(D1))
16624 c FFEINTRIN_impINDEX
16625 call fooI(INDEX(A1,A2))
16626 c FFEINTRIN_impISIGN
16627 call fooI(ISIGN(I1,I2))
16631 call fooL(LGE(A1,A2))
16633 call fooL(LGT(A1,A2))
16635 call fooL(LLE(A1,A2))
16637 call fooL(LLT(A1,A2))
16638 c FFEINTRIN_impMAX0
16639 call fooI(MAX0(I1,I2))
16640 c FFEINTRIN_impMAX1
16641 call fooI(MAX1(R1,R2))
16642 c FFEINTRIN_impMIN0
16643 call fooI(MIN0(I1,I2))
16644 c FFEINTRIN_impMIN1
16645 call fooI(MIN1(R1,R2))
16647 call fooI(MOD(I1,I2))
16648 c FFEINTRIN_impNINT
16649 call fooI(NINT(R1))
16650 c FFEINTRIN_impSIGN
16651 call fooR(SIGN(R1,R2))
16654 c FFEINTRIN_impSINH
16655 call fooR(SINH(R1))
16656 c FFEINTRIN_impSQRT
16657 call fooR(SQRT(R1))
16660 c FFEINTRIN_impTANH
16661 call fooR(TANH(R1))
16662 c FFEINTRIN_imp_CMPLX_C
16663 call fooC(cmplx(C1,C2))
16664 c FFEINTRIN_imp_CMPLX_D
16665 call fooZ(cmplx(D1,D2))
16666 c FFEINTRIN_imp_CMPLX_I
16667 call fooC(cmplx(I1,I2))
16668 c FFEINTRIN_imp_CMPLX_R
16669 call fooC(cmplx(R1,R2))
16670 c FFEINTRIN_imp_DBLE_C
16671 call fooD(dble(C1))
16672 c FFEINTRIN_imp_DBLE_D
16673 call fooD(dble(D1))
16674 c FFEINTRIN_imp_DBLE_I
16675 call fooD(dble(I1))
16676 c FFEINTRIN_imp_DBLE_R
16677 call fooD(dble(R1))
16678 c FFEINTRIN_imp_INT_C
16680 c FFEINTRIN_imp_INT_D
16682 c FFEINTRIN_imp_INT_I
16684 c FFEINTRIN_imp_INT_R
16686 c FFEINTRIN_imp_REAL_C
16687 call fooR(real(C1))
16688 c FFEINTRIN_imp_REAL_D
16689 call fooR(real(D1))
16690 c FFEINTRIN_imp_REAL_I
16691 call fooR(real(I1))
16692 c FFEINTRIN_imp_REAL_R
16693 call fooR(real(R1))
16695 c FFEINTRIN_imp_INT_D:
16697 c FFEINTRIN_specIDINT
16698 call fooI(IDINT(D1))
16700 c FFEINTRIN_imp_INT_R:
16702 c FFEINTRIN_specIFIX
16703 call fooI(IFIX(R1))
16704 c FFEINTRIN_specINT
16707 c FFEINTRIN_imp_REAL_D:
16709 c FFEINTRIN_specSNGL
16710 call fooR(SNGL(D1))
16712 c FFEINTRIN_imp_REAL_I:
16714 c FFEINTRIN_specFLOAT
16715 call fooR(FLOAT(I1))
16716 c FFEINTRIN_specREAL
16717 call fooR(REAL(I1))
16720 -------- (end input file to f2c)
16722 -------- (begin output from providing above input file as input to:
16723 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16724 -------- -e "s:^#.*$::g"')
16726 // -- translated by f2c (version 19950223).
16727 You must link the resulting object file with the libraries:
16728 -lf2c -lm (in that order)
16732 // f2c.h -- Standard Fortran to C header file //
16734 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16736 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16741 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16742 // we assume short, float are OK //
16743 typedef long int // long int // integer;
16744 typedef char *address;
16745 typedef short int shortint;
16746 typedef float real;
16747 typedef double doublereal;
16748 typedef struct { real r, i; } complex;
16749 typedef struct { doublereal r, i; } doublecomplex;
16750 typedef long int // long int // logical;
16751 typedef short int shortlogical;
16752 typedef char logical1;
16753 typedef char integer1;
16754 // typedef long long longint; // // system-dependent //
16759 // Extern is for use with -E //
16773 typedef long int // int or long int // flag;
16774 typedef long int // int or long int // ftnlen;
16775 typedef long int // int or long int // ftnint;
16778 //external read, write//
16787 //internal read, write//
16817 //rewind, backspace, endfile//
16829 ftnint *inex; //parameters in standard's order//
16855 union Multitype { // for multiple entry points //
16866 typedef union Multitype Multitype;
16868 typedef long Long; // No longer used; formerly in Namelist //
16870 struct Vardesc { // for Namelist //
16876 typedef struct Vardesc Vardesc;
16883 typedef struct Namelist Namelist;
16892 // procedure parameter types for -A and -C++ //
16897 typedef int // Unknown procedure type // (*U_fp)();
16898 typedef shortint (*J_fp)();
16899 typedef integer (*I_fp)();
16900 typedef real (*R_fp)();
16901 typedef doublereal (*D_fp)(), (*E_fp)();
16902 typedef // Complex // void (*C_fp)();
16903 typedef // Double Complex // void (*Z_fp)();
16904 typedef logical (*L_fp)();
16905 typedef shortlogical (*K_fp)();
16906 typedef // Character // void (*H_fp)();
16907 typedef // Subroutine // int (*S_fp)();
16909 // E_fp is for real functions when -R is not specified //
16910 typedef void C_f; // complex function //
16911 typedef void H_f; // character function //
16912 typedef void Z_f; // double complex function //
16913 typedef doublereal E_f; // real function with -R not specified //
16915 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16918 // (No such symbols should be defined in a strict ANSI C compiler.
16919 We can avoid trouble with f2c-translated code by using
16920 gcc -ansi [-traditional].) //
16944 // Main program // MAIN__()
16946 // System generated locals //
16949 doublereal d__1, d__2;
16951 doublecomplex z__1, z__2, z__3;
16955 // Builtin functions //
16958 double pow_ri(), pow_di();
16962 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16963 asin(), atan(), atan2(), c_abs();
16964 void c_cos(), c_exp(), c_log(), r_cnjg();
16965 double cos(), cosh();
16966 void c_sin(), c_sqrt();
16967 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16968 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16969 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16970 logical l_ge(), l_gt(), l_le(), l_lt();
16974 // Local variables //
16975 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16976 fool_(), fooz_(), getem_();
16977 static char a1[10], a2[10];
16978 static complex c1, c2;
16979 static doublereal d1, d2;
16980 static integer i1, i2;
16981 static real r1, r2;
16984 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16992 d__1 = (doublereal) i1;
16993 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
17003 c_div(&q__1, &c1, &c2);
17005 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
17007 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
17010 i__1 = pow_ii(&i1, &i2);
17012 r__1 = pow_ri(&r1, &i1);
17014 d__1 = pow_di(&d1, &i1);
17016 pow_ci(&q__1, &c1, &i1);
17018 d__1 = (doublereal) r1;
17019 d__2 = (doublereal) r2;
17020 r__1 = pow_dd(&d__1, &d__2);
17022 d__2 = (doublereal) r1;
17023 d__1 = pow_dd(&d__2, &d1);
17025 d__1 = pow_dd(&d1, &d2);
17027 d__2 = (doublereal) r1;
17028 d__1 = pow_dd(&d1, &d__2);
17030 z__2.r = c1.r, z__2.i = c1.i;
17031 z__3.r = c2.r, z__3.i = c2.i;
17032 pow_zz(&z__1, &z__2, &z__3);
17033 q__1.r = z__1.r, q__1.i = z__1.i;
17035 z__2.r = c1.r, z__2.i = c1.i;
17036 z__3.r = r1, z__3.i = 0.;
17037 pow_zz(&z__1, &z__2, &z__3);
17038 q__1.r = z__1.r, q__1.i = z__1.i;
17040 z__2.r = c1.r, z__2.i = c1.i;
17041 z__3.r = d1, z__3.i = 0.;
17042 pow_zz(&z__1, &z__2, &z__3);
17044 // FFEINTRIN_impABS //
17045 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
17047 // FFEINTRIN_impACOS //
17050 // FFEINTRIN_impAIMAG //
17051 r__1 = r_imag(&c1);
17053 // FFEINTRIN_impAINT //
17056 // FFEINTRIN_impALOG //
17059 // FFEINTRIN_impALOG10 //
17060 r__1 = r_lg10(&r1);
17062 // FFEINTRIN_impAMAX0 //
17063 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17065 // FFEINTRIN_impAMAX1 //
17066 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17068 // FFEINTRIN_impAMIN0 //
17069 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17071 // FFEINTRIN_impAMIN1 //
17072 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17074 // FFEINTRIN_impAMOD //
17075 r__1 = r_mod(&r1, &r2);
17077 // FFEINTRIN_impANINT //
17078 r__1 = r_nint(&r1);
17080 // FFEINTRIN_impASIN //
17083 // FFEINTRIN_impATAN //
17086 // FFEINTRIN_impATAN2 //
17087 r__1 = atan2(r1, r2);
17089 // FFEINTRIN_impCABS //
17092 // FFEINTRIN_impCCOS //
17095 // FFEINTRIN_impCEXP //
17098 // FFEINTRIN_impCHAR //
17099 *(unsigned char *)&ch__1[0] = i1;
17101 // FFEINTRIN_impCLOG //
17104 // FFEINTRIN_impCONJG //
17105 r_cnjg(&q__1, &c1);
17107 // FFEINTRIN_impCOS //
17110 // FFEINTRIN_impCOSH //
17113 // FFEINTRIN_impCSIN //
17116 // FFEINTRIN_impCSQRT //
17117 c_sqrt(&q__1, &c1);
17119 // FFEINTRIN_impDABS //
17120 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17122 // FFEINTRIN_impDACOS //
17125 // FFEINTRIN_impDASIN //
17128 // FFEINTRIN_impDATAN //
17131 // FFEINTRIN_impDATAN2 //
17132 d__1 = atan2(d1, d2);
17134 // FFEINTRIN_impDCOS //
17137 // FFEINTRIN_impDCOSH //
17140 // FFEINTRIN_impDDIM //
17141 d__1 = d_dim(&d1, &d2);
17143 // FFEINTRIN_impDEXP //
17146 // FFEINTRIN_impDIM //
17147 r__1 = r_dim(&r1, &r2);
17149 // FFEINTRIN_impDINT //
17152 // FFEINTRIN_impDLOG //
17155 // FFEINTRIN_impDLOG10 //
17156 d__1 = d_lg10(&d1);
17158 // FFEINTRIN_impDMAX1 //
17159 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17161 // FFEINTRIN_impDMIN1 //
17162 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17164 // FFEINTRIN_impDMOD //
17165 d__1 = d_mod(&d1, &d2);
17167 // FFEINTRIN_impDNINT //
17168 d__1 = d_nint(&d1);
17170 // FFEINTRIN_impDPROD //
17171 d__1 = (doublereal) r1 * r2;
17173 // FFEINTRIN_impDSIGN //
17174 d__1 = d_sign(&d1, &d2);
17176 // FFEINTRIN_impDSIN //
17179 // FFEINTRIN_impDSINH //
17182 // FFEINTRIN_impDSQRT //
17185 // FFEINTRIN_impDTAN //
17188 // FFEINTRIN_impDTANH //
17191 // FFEINTRIN_impEXP //
17194 // FFEINTRIN_impIABS //
17195 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17197 // FFEINTRIN_impICHAR //
17198 i__1 = *(unsigned char *)a1;
17200 // FFEINTRIN_impIDIM //
17201 i__1 = i_dim(&i1, &i2);
17203 // FFEINTRIN_impIDNINT //
17204 i__1 = i_dnnt(&d1);
17206 // FFEINTRIN_impINDEX //
17207 i__1 = i_indx(a1, a2, 10L, 10L);
17209 // FFEINTRIN_impISIGN //
17210 i__1 = i_sign(&i1, &i2);
17212 // FFEINTRIN_impLEN //
17213 i__1 = i_len(a1, 10L);
17215 // FFEINTRIN_impLGE //
17216 L__1 = l_ge(a1, a2, 10L, 10L);
17218 // FFEINTRIN_impLGT //
17219 L__1 = l_gt(a1, a2, 10L, 10L);
17221 // FFEINTRIN_impLLE //
17222 L__1 = l_le(a1, a2, 10L, 10L);
17224 // FFEINTRIN_impLLT //
17225 L__1 = l_lt(a1, a2, 10L, 10L);
17227 // FFEINTRIN_impMAX0 //
17228 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17230 // FFEINTRIN_impMAX1 //
17231 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17233 // FFEINTRIN_impMIN0 //
17234 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17236 // FFEINTRIN_impMIN1 //
17237 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17239 // FFEINTRIN_impMOD //
17242 // FFEINTRIN_impNINT //
17243 i__1 = i_nint(&r1);
17245 // FFEINTRIN_impSIGN //
17246 r__1 = r_sign(&r1, &r2);
17248 // FFEINTRIN_impSIN //
17251 // FFEINTRIN_impSINH //
17254 // FFEINTRIN_impSQRT //
17257 // FFEINTRIN_impTAN //
17260 // FFEINTRIN_impTANH //
17263 // FFEINTRIN_imp_CMPLX_C //
17266 q__1.r = r__1, q__1.i = r__2;
17268 // FFEINTRIN_imp_CMPLX_D //
17269 z__1.r = d1, z__1.i = d2;
17271 // FFEINTRIN_imp_CMPLX_I //
17274 q__1.r = r__1, q__1.i = r__2;
17276 // FFEINTRIN_imp_CMPLX_R //
17277 q__1.r = r1, q__1.i = r2;
17279 // FFEINTRIN_imp_DBLE_C //
17280 d__1 = (doublereal) c1.r;
17282 // FFEINTRIN_imp_DBLE_D //
17285 // FFEINTRIN_imp_DBLE_I //
17286 d__1 = (doublereal) i1;
17288 // FFEINTRIN_imp_DBLE_R //
17289 d__1 = (doublereal) r1;
17291 // FFEINTRIN_imp_INT_C //
17292 i__1 = (integer) c1.r;
17294 // FFEINTRIN_imp_INT_D //
17295 i__1 = (integer) d1;
17297 // FFEINTRIN_imp_INT_I //
17300 // FFEINTRIN_imp_INT_R //
17301 i__1 = (integer) r1;
17303 // FFEINTRIN_imp_REAL_C //
17306 // FFEINTRIN_imp_REAL_D //
17309 // FFEINTRIN_imp_REAL_I //
17312 // FFEINTRIN_imp_REAL_R //
17316 // FFEINTRIN_imp_INT_D: //
17318 // FFEINTRIN_specIDINT //
17319 i__1 = (integer) d1;
17322 // FFEINTRIN_imp_INT_R: //
17324 // FFEINTRIN_specIFIX //
17325 i__1 = (integer) r1;
17327 // FFEINTRIN_specINT //
17328 i__1 = (integer) r1;
17331 // FFEINTRIN_imp_REAL_D: //
17333 // FFEINTRIN_specSNGL //
17337 // FFEINTRIN_imp_REAL_I: //
17339 // FFEINTRIN_specFLOAT //
17342 // FFEINTRIN_specREAL //
17348 -------- (end output file from f2c)