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):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
89 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
93 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
95 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
97 /* BEGIN stuff from gcc/cccp.c. */
99 /* The following symbols should be autoconfigured:
106 In the mean time, we'll get by with approximations based
107 on existing GCC configuration symbols. */
110 # ifndef HAVE_STDLIB_H
111 # define HAVE_STDLIB_H 1
113 # ifndef HAVE_UNISTD_H
114 # define HAVE_UNISTD_H 1
116 # ifndef STDC_HEADERS
117 # define STDC_HEADERS 1
119 #endif /* defined (POSIX) */
121 #if defined (POSIX) || (defined (USG) && !defined (VMS))
122 # ifndef HAVE_FCNTL_H
123 # define HAVE_FCNTL_H 1
130 # if TIME_WITH_SYS_TIME
131 # include <sys/time.h>
135 # include <sys/time.h>
140 # include <sys/resource.h>
147 /* This defines "errno" properly for VMS, and gives us EACCES. */
160 /* VMS-specific definitions */
163 #define O_RDONLY 0 /* Open arg for Read/Only */
164 #define O_WRONLY 1 /* Open arg for Write/Only */
165 #define read(fd,buf,size) VMS_read (fd,buf,size)
166 #define write(fd,buf,size) VMS_write (fd,buf,size)
167 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
168 #define fopen(fname,mode) VMS_fopen (fname,mode)
169 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
170 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
171 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
172 static int VMS_fstat (), VMS_stat ();
173 static char * VMS_strncat ();
174 static int VMS_read ();
175 static int VMS_write ();
176 static int VMS_open ();
177 static FILE * VMS_fopen ();
178 static FILE * VMS_freopen ();
179 static void hack_vms_include_specification ();
180 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
181 #define ino_t vms_ino_t
182 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
189 /* END stuff from gcc/cccp.c. */
191 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
208 /* Externals defined here. */
210 #if FFECOM_targetCURRENT == FFECOM_targetGCC
212 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
215 const char * const language_string = "GNU F77";
217 /* Stream for reading from the input file. */
220 /* These definitions parallel those in c-decl.c so that code from that
221 module can be used pretty much as is. Much of these defs aren't
222 otherwise used, i.e. by g77 code per se, except some of them are used
223 to build some of them that are. The ones that are global (i.e. not
224 "static") are those that ste.c and such might use (directly
225 or by using com macros that reference them in their definitions). */
227 tree string_type_node;
229 /* The rest of these are inventions for g77, though there might be
230 similar things in the C front end. As they are found, these
231 inventions should be renamed to be canonical. Note that only
232 the ones currently required to be global are so. */
234 static tree ffecom_tree_fun_type_void;
236 tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
237 tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
238 tree ffecom_integer_one_node; /* " */
239 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
241 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
242 just use build_function_type and build_pointer_type on the
243 appropriate _tree_type array element. */
245 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
246 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
247 static tree ffecom_tree_subr_type;
248 static tree ffecom_tree_ptr_to_subr_type;
249 static tree ffecom_tree_blockdata_type;
251 static tree ffecom_tree_xargc_;
253 ffecomSymbol ffecom_symbol_null_
262 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
263 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
265 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
266 tree ffecom_f2c_integer_type_node;
267 tree ffecom_f2c_ptr_to_integer_type_node;
268 tree ffecom_f2c_address_type_node;
269 tree ffecom_f2c_real_type_node;
270 tree ffecom_f2c_ptr_to_real_type_node;
271 tree ffecom_f2c_doublereal_type_node;
272 tree ffecom_f2c_complex_type_node;
273 tree ffecom_f2c_doublecomplex_type_node;
274 tree ffecom_f2c_longint_type_node;
275 tree ffecom_f2c_logical_type_node;
276 tree ffecom_f2c_flag_type_node;
277 tree ffecom_f2c_ftnlen_type_node;
278 tree ffecom_f2c_ftnlen_zero_node;
279 tree ffecom_f2c_ftnlen_one_node;
280 tree ffecom_f2c_ftnlen_two_node;
281 tree ffecom_f2c_ptr_to_ftnlen_type_node;
282 tree ffecom_f2c_ftnint_type_node;
283 tree ffecom_f2c_ptr_to_ftnint_type_node;
284 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
286 /* Simple definitions and enumerations. */
288 #ifndef FFECOM_sizeMAXSTACKITEM
289 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
290 larger than this # bytes
291 off stack if possible. */
294 /* For systems that have large enough stacks, they should define
295 this to 0, and here, for ease of use later on, we just undefine
298 #if FFECOM_sizeMAXSTACKITEM == 0
299 #undef FFECOM_sizeMAXSTACKITEM
305 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
306 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
307 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
308 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
309 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
310 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
311 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
312 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
313 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
314 FFECOM_rttypeDOUBLE_, /* C's `double' type. */
315 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
316 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
317 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
318 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
322 /* Internal typedefs. */
324 #if FFECOM_targetCURRENT == FFECOM_targetGCC
325 typedef struct _ffecom_concat_list_ ffecomConcatList_;
326 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
328 /* Private include files. */
331 /* Internal structure definitions. */
333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
334 struct _ffecom_concat_list_
339 ffetargetCharacterSize minlen;
340 ffetargetCharacterSize maxlen;
342 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
344 /* Static functions (internal). */
346 #if FFECOM_targetCURRENT == FFECOM_targetGCC
347 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
348 static tree ffecom_widest_expr_type_ (ffebld list);
349 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
350 tree dest_size, tree source_tree,
351 ffebld source, bool scalar_arg);
352 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
353 tree args, tree callee_commons,
355 static tree ffecom_build_f2c_string_ (int i, const char *s);
356 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
357 bool is_f2c_complex, tree type,
358 tree args, tree dest_tree,
359 ffebld dest, bool *dest_used,
360 tree callee_commons, bool scalar_args, tree hook);
361 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
362 bool is_f2c_complex, tree type,
363 ffebld left, ffebld right,
364 tree dest_tree, ffebld dest,
365 bool *dest_used, tree callee_commons,
366 bool scalar_args, bool ref, tree hook);
367 static void ffecom_char_args_x_ (tree *xitem, tree *length,
368 ffebld expr, bool with_null);
369 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
370 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
371 static ffecomConcatList_
372 ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
374 ffetargetCharacterSize max);
375 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
376 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
377 ffetargetCharacterSize max);
378 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
379 ffesymbol member, tree member_type,
380 ffetargetOffset offset);
381 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
382 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
383 bool *dest_used, bool assignp, bool widenp);
384 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
385 ffebld dest, bool *dest_used);
386 static tree ffecom_expr_power_integer_ (ffebld expr);
387 static void ffecom_expr_transform_ (ffebld expr);
388 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
389 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
391 static ffeglobal ffecom_finish_global_ (ffeglobal global);
392 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
393 static tree ffecom_get_appended_identifier_ (char us, const char *text);
394 static tree ffecom_get_external_identifier_ (ffesymbol s);
395 static tree ffecom_get_identifier_ (const char *text);
396 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
399 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
400 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
401 static tree ffecom_init_zero_ (tree decl);
402 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
404 static tree ffecom_intrinsic_len_ (ffebld expr);
405 static void ffecom_let_char_ (tree dest_tree,
407 ffetargetCharacterSize dest_size,
409 static void ffecom_make_gfrt_ (ffecomGfrt ix);
410 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
411 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
412 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
414 static void ffecom_push_dummy_decls_ (ffebld dumlist,
416 static void ffecom_start_progunit_ (void);
417 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
418 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
419 static void ffecom_transform_common_ (ffesymbol s);
420 static void ffecom_transform_equiv_ (ffestorag st);
421 static tree ffecom_transform_namelist_ (ffesymbol s);
422 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
424 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
425 tree *size, tree tree);
426 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
427 tree dest_tree, ffebld dest,
428 bool *dest_used, tree hook);
429 static tree ffecom_type_localvar_ (ffesymbol s,
432 static tree ffecom_type_namelist_ (void);
433 static tree ffecom_type_vardesc_ (void);
434 static tree ffecom_vardesc_ (ffebld expr);
435 static tree ffecom_vardesc_array_ (ffesymbol s);
436 static tree ffecom_vardesc_dims_ (ffesymbol s);
437 static tree ffecom_convert_narrow_ (tree type, tree expr);
438 static tree ffecom_convert_widen_ (tree type, tree expr);
439 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
441 /* These are static functions that parallel those found in the C front
442 end and thus have the same names. */
444 #if FFECOM_targetCURRENT == FFECOM_targetGCC
445 static tree bison_rule_compstmt_ (void);
446 static void bison_rule_pushlevel_ (void);
447 static void delete_block (tree block);
448 static int duplicate_decls (tree newdecl, tree olddecl);
449 static void finish_decl (tree decl, tree init, bool is_top_level);
450 static void finish_function (int nested);
451 static const char *lang_printable_name (tree decl, int v);
452 static tree lookup_name_current_level (tree name);
453 static struct binding_level *make_binding_level (void);
454 static void pop_f_function_context (void);
455 static void push_f_function_context (void);
456 static void push_parm_decl (tree parm);
457 static tree pushdecl_top_level (tree decl);
458 static int kept_level_p (void);
459 static tree storedecls (tree decls);
460 static void store_parm_decls (int is_main_program);
461 static tree start_decl (tree decl, bool is_top_level);
462 static void start_function (tree name, tree type, int nested, int public);
463 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
464 #if FFECOM_GCC_INCLUDE
465 static void ffecom_file_ (const char *name);
466 static void ffecom_initialize_char_syntax_ (void);
467 static void ffecom_close_include_ (FILE *f);
468 static int ffecom_decode_include_option_ (char *spec);
469 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
471 #endif /* FFECOM_GCC_INCLUDE */
473 /* Static objects accessed by functions in this module. */
475 static ffesymbol ffecom_primary_entry_ = NULL;
476 static ffesymbol ffecom_nested_entry_ = NULL;
477 static ffeinfoKind ffecom_primary_entry_kind_;
478 static bool ffecom_primary_entry_is_proc_;
479 #if FFECOM_targetCURRENT == FFECOM_targetGCC
480 static tree ffecom_outer_function_decl_;
481 static tree ffecom_previous_function_decl_;
482 static tree ffecom_which_entrypoint_decl_;
483 static tree ffecom_float_zero_ = NULL_TREE;
484 static tree ffecom_float_half_ = NULL_TREE;
485 static tree ffecom_double_zero_ = NULL_TREE;
486 static tree ffecom_double_half_ = NULL_TREE;
487 static tree ffecom_func_result_;/* For functions. */
488 static tree ffecom_func_length_;/* For CHARACTER fns. */
489 static ffebld ffecom_list_blockdata_;
490 static ffebld ffecom_list_common_;
491 static ffebld ffecom_master_arglist_;
492 static ffeinfoBasictype ffecom_master_bt_;
493 static ffeinfoKindtype ffecom_master_kt_;
494 static ffetargetCharacterSize ffecom_master_size_;
495 static int ffecom_num_fns_ = 0;
496 static int ffecom_num_entrypoints_ = 0;
497 static bool ffecom_is_altreturning_ = FALSE;
498 static tree ffecom_multi_type_node_;
499 static tree ffecom_multi_retval_;
501 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
502 static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
503 static bool ffecom_doing_entry_ = FALSE;
504 static bool ffecom_transform_only_dummies_ = FALSE;
505 static int ffecom_typesize_pointer_;
506 static int ffecom_typesize_integer1_;
508 /* Holds pointer-to-function expressions. */
510 static tree ffecom_gfrt_[FFECOM_gfrt]
513 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
514 #include "com-rt.def"
518 /* Holds the external names of the functions. */
520 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
523 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
524 #include "com-rt.def"
528 /* Whether the function returns. */
530 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
533 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
534 #include "com-rt.def"
538 /* Whether the function returns type complex. */
540 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
543 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
544 #include "com-rt.def"
548 /* Whether the function is const
549 (i.e., has no side effects and only depends on its arguments). */
551 static bool ffecom_gfrt_const_[FFECOM_gfrt]
554 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
555 #include "com-rt.def"
559 /* Type code for the function return value. */
561 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
564 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
565 #include "com-rt.def"
569 /* String of codes for the function's arguments. */
571 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
574 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
575 #include "com-rt.def"
578 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
580 /* Internal macros. */
582 #if FFECOM_targetCURRENT == FFECOM_targetGCC
584 /* We let tm.h override the types used here, to handle trivial differences
585 such as the choice of unsigned int or long unsigned int for size_t.
586 When machines start needing nontrivial differences in the size type,
587 it would be best to do something here to figure out automatically
588 from other information what type to use. */
591 #define SIZE_TYPE "long unsigned int"
594 #define ffecom_concat_list_count_(catlist) ((catlist).count)
595 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
596 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
597 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
599 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
600 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
602 /* For each binding contour we allocate a binding_level structure
603 * which records the names defined in that contour.
606 * 1) one for each function definition,
607 * where internal declarations of the parameters appear.
609 * The current meaning of a name can be found by searching the levels from
610 * the current one out to the global one.
613 /* Note that the information in the `names' component of the global contour
614 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
618 /* A chain of _DECL nodes for all variables, constants, functions,
619 and typedef types. These are in the reverse of the order supplied.
623 /* For each level (except not the global one),
624 a chain of BLOCK nodes for all the levels
625 that were entered and exited one level down. */
628 /* The BLOCK node for this level, if one has been preallocated.
629 If 0, the BLOCK is allocated (if needed) when the level is popped. */
632 /* The binding level which this one is contained in (inherits from). */
633 struct binding_level *level_chain;
635 /* 0: no ffecom_prepare_* functions called at this level yet;
636 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
637 2: ffecom_prepare_end called. */
641 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
643 /* The binding level currently in effect. */
645 static struct binding_level *current_binding_level;
647 /* A chain of binding_level structures awaiting reuse. */
649 static struct binding_level *free_binding_level;
651 /* The outermost binding level, for names of file scope.
652 This is created when the compiler is started and exists
653 through the entire run. */
655 static struct binding_level *global_binding_level;
657 /* Binding level structures are initialized by copying this one. */
659 static struct binding_level clear_binding_level
661 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
663 /* Language-dependent contents of an identifier. */
665 struct lang_identifier
667 struct tree_identifier ignore;
668 tree global_value, local_value, label_value;
672 /* Macros for access to language-specific slots in an identifier. */
673 /* Each of these slots contains a DECL node or null. */
675 /* This represents the value which the identifier has in the
676 file-scope namespace. */
677 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
678 (((struct lang_identifier *)(NODE))->global_value)
679 /* This represents the value which the identifier has in the current
681 #define IDENTIFIER_LOCAL_VALUE(NODE) \
682 (((struct lang_identifier *)(NODE))->local_value)
683 /* This represents the value which the identifier has as a label in
684 the current label scope. */
685 #define IDENTIFIER_LABEL_VALUE(NODE) \
686 (((struct lang_identifier *)(NODE))->label_value)
687 /* This is nonzero if the identifier was "made up" by g77 code. */
688 #define IDENTIFIER_INVENTED(NODE) \
689 (((struct lang_identifier *)(NODE))->invented)
691 /* In identifiers, C uses the following fields in a special way:
692 TREE_PUBLIC to record that there was a previous local extern decl.
693 TREE_USED to record that such a decl was used.
694 TREE_ADDRESSABLE to record that the address of such a decl was used. */
696 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
697 that have names. Here so we can clear out their names' definitions
698 at the end of the function. */
700 static tree named_labels;
702 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
704 static tree shadowed_labels;
706 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
708 /* Return the subscript expression, modified to do range-checking.
710 `array' is the array to be checked against.
711 `element' is the subscript expression to check.
712 `dim' is the dimension number (starting at 0).
713 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
717 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
718 const char *array_name)
720 tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
721 tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
726 if (element == error_mark_node)
729 if (TREE_TYPE (low) != TREE_TYPE (element))
731 if (TYPE_PRECISION (TREE_TYPE (low))
732 > TYPE_PRECISION (TREE_TYPE (element)))
733 element = convert (TREE_TYPE (low), element);
736 low = convert (TREE_TYPE (element), low);
738 high = convert (TREE_TYPE (element), high);
742 element = ffecom_save_tree (element);
743 cond = ffecom_2 (LE_EXPR, integer_type_node,
748 cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
750 ffecom_2 (LE_EXPR, integer_type_node,
767 var = xmalloc (strlen (array_name) + 20);
768 sprintf (var, "%s[%s-substring]",
770 dim ? "end" : "start");
771 len = strlen (var) + 1;
772 arg1 = build_string (len, var);
777 len = strlen (array_name) + 1;
778 arg1 = build_string (len, array_name);
782 var = xmalloc (strlen (array_name) + 40);
783 sprintf (var, "%s[subscript-%d-of-%d]",
785 dim + 1, total_dims);
786 len = strlen (var) + 1;
787 arg1 = build_string (len, var);
793 = build_type_variant (build_array_type (char_type_node,
797 build_int_2 (len, 0))),
799 TREE_CONSTANT (arg1) = 1;
800 TREE_STATIC (arg1) = 1;
801 arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
804 /* s_rnge adds one to the element to print it, so bias against
805 that -- want to print a faithful *subscript* value. */
806 arg2 = convert (ffecom_f2c_ftnint_type_node,
807 ffecom_2 (MINUS_EXPR,
810 convert (TREE_TYPE (element),
813 proc = xmalloc ((len = strlen (input_filename)
814 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
817 sprintf (&proc[0], "%s/%s",
819 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
820 arg3 = build_string (len, proc);
825 = build_type_variant (build_array_type (char_type_node,
829 build_int_2 (len, 0))),
831 TREE_CONSTANT (arg3) = 1;
832 TREE_STATIC (arg3) = 1;
833 arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
836 arg4 = convert (ffecom_f2c_ftnint_type_node,
837 build_int_2 (lineno, 0));
839 arg1 = build_tree_list (NULL_TREE, arg1);
840 arg2 = build_tree_list (NULL_TREE, arg2);
841 arg3 = build_tree_list (NULL_TREE, arg3);
842 arg4 = build_tree_list (NULL_TREE, arg4);
843 TREE_CHAIN (arg3) = arg4;
844 TREE_CHAIN (arg2) = arg3;
845 TREE_CHAIN (arg1) = arg2;
849 die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
851 TREE_SIDE_EFFECTS (die) = 1;
853 element = ffecom_3 (COND_EXPR,
862 /* Return the computed element of an array reference.
864 `item' is NULL_TREE, or the transformed pointer to the array.
865 `expr' is the original opARRAYREF expression, which is transformed
866 if `item' is NULL_TREE.
867 `want_ptr' is non-zero if a pointer to the element, instead of
868 the element itself, is to be returned. */
871 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
873 ffebld dims[FFECOM_dimensionsMAX];
876 int flatten = ffe_is_flatten_arrays ();
882 const char *array_name;
886 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
887 array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
889 array_name = "[expr?]";
891 /* Build up ARRAY_REFs in reverse order (since we're column major
892 here in Fortran land). */
894 for (i = 0, list = ffebld_right (expr);
896 ++i, list = ffebld_trail (list))
898 dims[i] = ffebld_head (list);
899 type = ffeinfo_type (ffebld_basictype (dims[i]),
900 ffebld_kindtype (dims[i]));
902 && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
903 && ffetype_size (type) > ffecom_typesize_integer1_)
904 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
905 pointers and 32-bit integers. Do the full 64-bit pointer
906 arithmetic, for codes using arrays for nonstandard heap-like
913 need_ptr = want_ptr || flatten;
918 item = ffecom_ptr_to_expr (ffebld_left (expr));
920 item = ffecom_expr (ffebld_left (expr));
922 if (item == error_mark_node)
925 if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
926 && ! mark_addressable (item))
927 return error_mark_node;
930 if (item == error_mark_node)
937 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
939 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
941 min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
942 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
943 if (flag_bounds_check)
944 element = ffecom_subscript_check_ (array, element, i, total_dims,
946 if (element == error_mark_node)
949 /* Widen integral arithmetic as desired while preserving
951 tree_type = TREE_TYPE (element);
952 tree_type_x = tree_type;
954 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
955 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
956 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
958 if (TREE_TYPE (min) != tree_type_x)
959 min = convert (tree_type_x, min);
960 if (TREE_TYPE (element) != tree_type_x)
961 element = convert (tree_type_x, element);
963 item = ffecom_2 (PLUS_EXPR,
964 build_pointer_type (TREE_TYPE (array)),
966 size_binop (MULT_EXPR,
967 size_in_bytes (TREE_TYPE (array)),
969 fold (build (MINUS_EXPR,
975 item = ffecom_1 (INDIRECT_REF,
976 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
986 array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
988 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
989 if (flag_bounds_check)
990 element = ffecom_subscript_check_ (array, element, i, total_dims,
992 if (element == error_mark_node)
995 /* Widen integral arithmetic as desired while preserving
997 tree_type = TREE_TYPE (element);
998 tree_type_x = tree_type;
1000 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1001 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1002 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1004 element = convert (tree_type_x, element);
1006 item = ffecom_2 (ARRAY_REF,
1007 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1016 /* This is like gcc's stabilize_reference -- in fact, most of the code
1017 comes from that -- but it handles the situation where the reference
1018 is going to have its subparts picked at, and it shouldn't change
1019 (or trigger extra invocations of functions in the subtrees) due to
1020 this. save_expr is a bit overzealous, because we don't need the
1021 entire thing calculated and saved like a temp. So, for DECLs, no
1022 change is needed, because these are stable aggregates, and ARRAY_REF
1023 and such might well be stable too, but for things like calculations,
1024 we do need to calculate a snapshot of a value before picking at it. */
1026 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1028 ffecom_stabilize_aggregate_ (tree ref)
1031 enum tree_code code = TREE_CODE (ref);
1038 /* No action is needed in this case. */
1044 case FIX_TRUNC_EXPR:
1045 case FIX_FLOOR_EXPR:
1046 case FIX_ROUND_EXPR:
1048 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1052 result = build_nt (INDIRECT_REF,
1053 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1057 result = build_nt (COMPONENT_REF,
1058 stabilize_reference (TREE_OPERAND (ref, 0)),
1059 TREE_OPERAND (ref, 1));
1063 result = build_nt (BIT_FIELD_REF,
1064 stabilize_reference (TREE_OPERAND (ref, 0)),
1065 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1066 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1070 result = build_nt (ARRAY_REF,
1071 stabilize_reference (TREE_OPERAND (ref, 0)),
1072 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1076 result = build_nt (COMPOUND_EXPR,
1077 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1078 stabilize_reference (TREE_OPERAND (ref, 1)));
1086 return save_expr (ref);
1089 return error_mark_node;
1092 TREE_TYPE (result) = TREE_TYPE (ref);
1093 TREE_READONLY (result) = TREE_READONLY (ref);
1094 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1095 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1101 /* A rip-off of gcc's convert.c convert_to_complex function,
1102 reworked to handle complex implemented as C structures
1103 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1107 ffecom_convert_to_complex_ (tree type, tree expr)
1109 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1112 assert (TREE_CODE (type) == RECORD_TYPE);
1114 subtype = TREE_TYPE (TYPE_FIELDS (type));
1116 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1118 expr = convert (subtype, expr);
1119 return ffecom_2 (COMPLEX_EXPR, type, expr,
1120 convert (subtype, integer_zero_node));
1123 if (form == RECORD_TYPE)
1125 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1126 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1130 expr = save_expr (expr);
1131 return ffecom_2 (COMPLEX_EXPR,
1134 ffecom_1 (REALPART_EXPR,
1135 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1138 ffecom_1 (IMAGPART_EXPR,
1139 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1144 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1145 error ("pointer value used where a complex was expected");
1147 error ("aggregate value used where a complex was expected");
1149 return ffecom_2 (COMPLEX_EXPR, type,
1150 convert (subtype, integer_zero_node),
1151 convert (subtype, integer_zero_node));
1155 /* Like gcc's convert(), but crashes if widening might happen. */
1157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1159 ffecom_convert_narrow_ (type, expr)
1162 register tree e = expr;
1163 register enum tree_code code = TREE_CODE (type);
1165 if (type == TREE_TYPE (e)
1166 || TREE_CODE (e) == ERROR_MARK)
1168 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1169 return fold (build1 (NOP_EXPR, type, e));
1170 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1171 || code == ERROR_MARK)
1172 return error_mark_node;
1173 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1175 assert ("void value not ignored as it ought to be" == NULL);
1176 return error_mark_node;
1178 assert (code != VOID_TYPE);
1179 if ((code != RECORD_TYPE)
1180 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1181 assert ("converting COMPLEX to REAL" == NULL);
1182 assert (code != ENUMERAL_TYPE);
1183 if (code == INTEGER_TYPE)
1185 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1186 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1187 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1188 && (TYPE_PRECISION (type)
1189 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1190 return fold (convert_to_integer (type, e));
1192 if (code == POINTER_TYPE)
1194 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1195 return fold (convert_to_pointer (type, e));
1197 if (code == REAL_TYPE)
1199 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1200 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1201 return fold (convert_to_real (type, e));
1203 if (code == COMPLEX_TYPE)
1205 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1206 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1207 return fold (convert_to_complex (type, e));
1209 if (code == RECORD_TYPE)
1211 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1212 /* Check that at least the first field name agrees. */
1213 assert (DECL_NAME (TYPE_FIELDS (type))
1214 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1215 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1216 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1217 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1218 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1220 return fold (ffecom_convert_to_complex_ (type, e));
1223 assert ("conversion to non-scalar type requested" == NULL);
1224 return error_mark_node;
1228 /* Like gcc's convert(), but crashes if narrowing might happen. */
1230 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 ffecom_convert_widen_ (type, expr)
1235 register tree e = expr;
1236 register enum tree_code code = TREE_CODE (type);
1238 if (type == TREE_TYPE (e)
1239 || TREE_CODE (e) == ERROR_MARK)
1241 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1242 return fold (build1 (NOP_EXPR, type, e));
1243 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1244 || code == ERROR_MARK)
1245 return error_mark_node;
1246 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1248 assert ("void value not ignored as it ought to be" == NULL);
1249 return error_mark_node;
1251 assert (code != VOID_TYPE);
1252 if ((code != RECORD_TYPE)
1253 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1254 assert ("narrowing COMPLEX to REAL" == NULL);
1255 assert (code != ENUMERAL_TYPE);
1256 if (code == INTEGER_TYPE)
1258 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1259 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1260 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1261 && (TYPE_PRECISION (type)
1262 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1263 return fold (convert_to_integer (type, e));
1265 if (code == POINTER_TYPE)
1267 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1268 return fold (convert_to_pointer (type, e));
1270 if (code == REAL_TYPE)
1272 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1273 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1274 return fold (convert_to_real (type, e));
1276 if (code == COMPLEX_TYPE)
1278 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1279 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1280 return fold (convert_to_complex (type, e));
1282 if (code == RECORD_TYPE)
1284 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1285 /* Check that at least the first field name agrees. */
1286 assert (DECL_NAME (TYPE_FIELDS (type))
1287 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1288 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1289 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1290 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1291 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1293 return fold (ffecom_convert_to_complex_ (type, e));
1296 assert ("conversion to non-scalar type requested" == NULL);
1297 return error_mark_node;
1301 /* Handles making a COMPLEX type, either the standard
1302 (but buggy?) gbe way, or the safer (but less elegant?)
1305 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1307 ffecom_make_complex_type_ (tree subtype)
1313 if (ffe_is_emulate_complex ())
1315 type = make_node (RECORD_TYPE);
1316 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1317 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1318 TYPE_FIELDS (type) = realfield;
1323 type = make_node (COMPLEX_TYPE);
1324 TREE_TYPE (type) = subtype;
1332 /* Chooses either the gbe or the f2c way to build a
1333 complex constant. */
1335 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1337 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1341 if (ffe_is_emulate_complex ())
1343 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1344 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1345 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1349 bothparts = build_complex (type, realpart, imagpart);
1356 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1358 ffecom_arglist_expr_ (const char *c, ffebld expr)
1361 tree *plist = &list;
1362 tree trail = NULL_TREE; /* Append char length args here. */
1363 tree *ptrail = &trail;
1368 tree wanted = NULL_TREE;
1369 static char zed[] = "0";
1374 while (expr != NULL)
1397 wanted = ffecom_f2c_complex_type_node;
1401 wanted = ffecom_f2c_doublereal_type_node;
1405 wanted = ffecom_f2c_doublecomplex_type_node;
1409 wanted = ffecom_f2c_real_type_node;
1413 wanted = ffecom_f2c_integer_type_node;
1417 wanted = ffecom_f2c_longint_type_node;
1421 assert ("bad argstring code" == NULL);
1427 exprh = ffebld_head (expr);
1431 if ((wanted == NULL_TREE)
1434 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1435 [ffeinfo_kindtype (ffebld_info (exprh))])
1436 == TYPE_MODE (wanted))))
1438 = build_tree_list (NULL_TREE,
1439 ffecom_arg_ptr_to_expr (exprh,
1443 item = ffecom_arg_expr (exprh, &length);
1444 item = ffecom_convert_widen_ (wanted, item);
1447 item = ffecom_1 (ADDR_EXPR,
1448 build_pointer_type (TREE_TYPE (item)),
1452 = build_tree_list (NULL_TREE,
1456 plist = &TREE_CHAIN (*plist);
1457 expr = ffebld_trail (expr);
1458 if (length != NULL_TREE)
1460 *ptrail = build_tree_list (NULL_TREE, length);
1461 ptrail = &TREE_CHAIN (*ptrail);
1465 /* We've run out of args in the call; if the implementation expects
1466 more, supply null pointers for them, which the implementation can
1467 check to see if an arg was omitted. */
1469 while (*c != '\0' && *c != '0')
1474 assert ("missing arg to run-time routine!" == NULL);
1489 assert ("bad arg string code" == NULL);
1493 = build_tree_list (NULL_TREE,
1495 plist = &TREE_CHAIN (*plist);
1504 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1506 ffecom_widest_expr_type_ (ffebld list)
1509 ffebld widest = NULL;
1511 ffetype widest_type = NULL;
1514 for (; list != NULL; list = ffebld_trail (list))
1516 item = ffebld_head (list);
1519 if ((widest != NULL)
1520 && (ffeinfo_basictype (ffebld_info (item))
1521 != ffeinfo_basictype (ffebld_info (widest))))
1523 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1524 ffeinfo_kindtype (ffebld_info (item)));
1525 if ((widest == FFEINFO_kindtypeNONE)
1526 || (ffetype_size (type)
1527 > ffetype_size (widest_type)))
1534 assert (widest != NULL);
1535 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1536 [ffeinfo_kindtype (ffebld_info (widest))];
1537 assert (t != NULL_TREE);
1542 /* Check whether a partial overlap between two expressions is possible.
1544 Can *starting* to write a portion of expr1 change the value
1545 computed (perhaps already, *partially*) by expr2?
1547 Currently, this is a concern only for a COMPLEX expr1. But if it
1548 isn't in COMMON or local EQUIVALENCE, since we don't support
1549 aliasing of arguments, it isn't a concern. */
1552 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1557 switch (ffebld_op (expr1))
1559 case FFEBLD_opSYMTER:
1560 sym = ffebld_symter (expr1);
1563 case FFEBLD_opARRAYREF:
1564 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1566 sym = ffebld_symter (ffebld_left (expr1));
1573 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1574 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1575 || ! (st = ffesymbol_storage (sym))
1576 || ! ffestorag_parent (st)))
1579 /* It's in COMMON or local EQUIVALENCE. */
1584 /* Check whether dest and source might overlap. ffebld versions of these
1585 might or might not be passed, will be NULL if not.
1587 The test is really whether source_tree is modifiable and, if modified,
1588 might overlap destination such that the value(s) in the destination might
1589 change before it is finally modified. dest_* are the canonized
1590 destination itself. */
1592 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1594 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1595 tree source_tree, ffebld source UNUSED,
1603 if (source_tree == NULL_TREE)
1606 switch (TREE_CODE (source_tree))
1609 case IDENTIFIER_NODE:
1620 case TRUNC_DIV_EXPR:
1622 case FLOOR_DIV_EXPR:
1623 case ROUND_DIV_EXPR:
1624 case TRUNC_MOD_EXPR:
1626 case FLOOR_MOD_EXPR:
1627 case ROUND_MOD_EXPR:
1629 case EXACT_DIV_EXPR:
1630 case FIX_TRUNC_EXPR:
1632 case FIX_FLOOR_EXPR:
1633 case FIX_ROUND_EXPR:
1648 case BIT_ANDTC_EXPR:
1650 case TRUTH_ANDIF_EXPR:
1651 case TRUTH_ORIF_EXPR:
1652 case TRUTH_AND_EXPR:
1654 case TRUTH_XOR_EXPR:
1655 case TRUTH_NOT_EXPR:
1671 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1672 TREE_OPERAND (source_tree, 1), NULL,
1676 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1677 TREE_OPERAND (source_tree, 0), NULL,
1682 case NON_LVALUE_EXPR:
1684 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1687 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1689 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1694 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1695 TREE_OPERAND (source_tree, 1), NULL,
1697 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1698 TREE_OPERAND (source_tree, 2), NULL,
1703 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1705 TREE_OPERAND (source_tree, 0));
1709 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1712 source_decl = source_tree;
1713 source_offset = bitsize_zero_node;
1714 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1718 case REFERENCE_EXPR:
1719 case PREDECREMENT_EXPR:
1720 case PREINCREMENT_EXPR:
1721 case POSTDECREMENT_EXPR:
1722 case POSTINCREMENT_EXPR:
1730 /* Come here when source_decl, source_offset, and source_size filled
1731 in appropriately. */
1733 if (source_decl == NULL_TREE)
1734 return FALSE; /* No decl involved, so no overlap. */
1736 if (source_decl != dest_decl)
1737 return FALSE; /* Different decl, no overlap. */
1739 if (TREE_CODE (dest_size) == ERROR_MARK)
1740 return TRUE; /* Assignment into entire assumed-size
1741 array? Shouldn't happen.... */
1743 t = ffecom_2 (LE_EXPR, integer_type_node,
1744 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1746 convert (TREE_TYPE (dest_offset),
1748 convert (TREE_TYPE (dest_offset),
1751 if (integer_onep (t))
1752 return FALSE; /* Destination precedes source. */
1755 || (source_size == NULL_TREE)
1756 || (TREE_CODE (source_size) == ERROR_MARK)
1757 || integer_zerop (source_size))
1758 return TRUE; /* No way to tell if dest follows source. */
1760 t = ffecom_2 (LE_EXPR, integer_type_node,
1761 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1763 convert (TREE_TYPE (source_offset),
1765 convert (TREE_TYPE (source_offset),
1768 if (integer_onep (t))
1769 return FALSE; /* Destination follows source. */
1771 return TRUE; /* Destination and source overlap. */
1775 /* Check whether dest might overlap any of a list of arguments or is
1776 in a COMMON area the callee might know about (and thus modify). */
1778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1780 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1781 tree args, tree callee_commons,
1789 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1792 if (dest_decl == NULL_TREE)
1793 return FALSE; /* Seems unlikely! */
1795 /* If the decl cannot be determined reliably, or if its in COMMON
1796 and the callee isn't known to not futz with COMMON via other
1797 means, overlap might happen. */
1799 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1800 || ((callee_commons != NULL_TREE)
1801 && TREE_PUBLIC (dest_decl)))
1804 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1806 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1807 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1808 arg, NULL, scalar_args))
1816 /* Build a string for a variable name as used by NAMELIST. This means that
1817 if we're using the f2c library, we build an uppercase string, since
1820 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1822 ffecom_build_f2c_string_ (int i, const char *s)
1824 if (!ffe_is_f2c_library ())
1825 return build_string (i, s);
1834 if (((size_t) i) > ARRAY_SIZE (space))
1835 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1839 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1843 t = build_string (i, tmp);
1845 if (((size_t) i) > ARRAY_SIZE (space))
1846 malloc_kill_ks (malloc_pool_image (), tmp, i);
1853 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1854 type to just get whatever the function returns), handling the
1855 f2c value-returning convention, if required, by prepending
1856 to the arglist a pointer to a temporary to receive the return value. */
1858 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1860 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1861 tree type, tree args, tree dest_tree,
1862 ffebld dest, bool *dest_used, tree callee_commons,
1863 bool scalar_args, tree hook)
1868 if (dest_used != NULL)
1873 if ((dest_used == NULL)
1875 || (ffeinfo_basictype (ffebld_info (dest))
1876 != FFEINFO_basictypeCOMPLEX)
1877 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1878 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1879 || ffecom_args_overlapping_ (dest_tree, dest, args,
1884 tempvar = ffecom_make_tempvar (ffecom_tree_type
1885 [FFEINFO_basictypeCOMPLEX][kt],
1886 FFETARGET_charactersizeNONE,
1896 tempvar = dest_tree;
1901 = build_tree_list (NULL_TREE,
1902 ffecom_1 (ADDR_EXPR,
1903 build_pointer_type (TREE_TYPE (tempvar)),
1905 TREE_CHAIN (item) = args;
1907 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1910 if (tempvar != dest_tree)
1911 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1914 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1917 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1918 item = ffecom_convert_narrow_ (type, item);
1924 /* Given two arguments, transform them and make a call to the given
1925 function via ffecom_call_. */
1927 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1929 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1930 tree type, ffebld left, ffebld right,
1931 tree dest_tree, ffebld dest, bool *dest_used,
1932 tree callee_commons, bool scalar_args, bool ref, tree hook)
1941 /* Pass arguments by reference. */
1942 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1943 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1947 /* Pass arguments by value. */
1948 left_tree = ffecom_arg_expr (left, &left_length);
1949 right_tree = ffecom_arg_expr (right, &right_length);
1953 left_tree = build_tree_list (NULL_TREE, left_tree);
1954 right_tree = build_tree_list (NULL_TREE, right_tree);
1955 TREE_CHAIN (left_tree) = right_tree;
1957 if (left_length != NULL_TREE)
1959 left_length = build_tree_list (NULL_TREE, left_length);
1960 TREE_CHAIN (right_tree) = left_length;
1963 if (right_length != NULL_TREE)
1965 right_length = build_tree_list (NULL_TREE, right_length);
1966 if (left_length != NULL_TREE)
1967 TREE_CHAIN (left_length) = right_length;
1969 TREE_CHAIN (right_tree) = right_length;
1972 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1973 dest_tree, dest, dest_used, callee_commons,
1978 /* Return ptr/length args for char subexpression
1980 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1981 subexpressions by constructing the appropriate trees for the ptr-to-
1982 character-text and length-of-character-text arguments in a calling
1985 Note that if with_null is TRUE, and the expression is an opCONTER,
1986 a null byte is appended to the string. */
1988 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1990 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1994 ffetargetCharacter1 val;
1995 ffetargetCharacterSize newlen;
1997 switch (ffebld_op (expr))
1999 case FFEBLD_opCONTER:
2000 val = ffebld_constant_character1 (ffebld_conter (expr));
2001 newlen = ffetarget_length_character1 (val);
2004 /* Begin FFETARGET-NULL-KLUDGE. */
2008 *length = build_int_2 (newlen, 0);
2009 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2010 high = build_int_2 (newlen, 0);
2011 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2012 item = build_string (newlen,
2013 ffetarget_text_character1 (val));
2014 /* End FFETARGET-NULL-KLUDGE. */
2016 = build_type_variant
2020 (ffecom_f2c_ftnlen_type_node,
2021 ffecom_f2c_ftnlen_one_node,
2024 TREE_CONSTANT (item) = 1;
2025 TREE_STATIC (item) = 1;
2026 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2030 case FFEBLD_opSYMTER:
2032 ffesymbol s = ffebld_symter (expr);
2034 item = ffesymbol_hook (s).decl_tree;
2035 if (item == NULL_TREE)
2037 s = ffecom_sym_transform_ (s);
2038 item = ffesymbol_hook (s).decl_tree;
2040 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2042 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2043 *length = ffesymbol_hook (s).length_tree;
2046 *length = build_int_2 (ffesymbol_size (s), 0);
2047 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2050 else if (item == error_mark_node)
2051 *length = error_mark_node;
2053 /* FFEINFO_kindFUNCTION. */
2054 *length = NULL_TREE;
2055 if (!ffesymbol_hook (s).addr
2056 && (item != error_mark_node))
2057 item = ffecom_1 (ADDR_EXPR,
2058 build_pointer_type (TREE_TYPE (item)),
2063 case FFEBLD_opARRAYREF:
2065 ffecom_char_args_ (&item, length, ffebld_left (expr));
2067 if (item == error_mark_node || *length == error_mark_node)
2069 item = *length = error_mark_node;
2073 item = ffecom_arrayref_ (item, expr, 1);
2077 case FFEBLD_opSUBSTR:
2081 ffebld thing = ffebld_right (expr);
2084 const char *char_name;
2088 assert (ffebld_op (thing) == FFEBLD_opITEM);
2089 start = ffebld_head (thing);
2090 thing = ffebld_trail (thing);
2091 assert (ffebld_trail (thing) == NULL);
2092 end = ffebld_head (thing);
2094 /* Determine name for pretty-printing range-check errors. */
2095 for (left_symter = ffebld_left (expr);
2096 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2097 left_symter = ffebld_left (left_symter))
2099 if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2100 char_name = ffesymbol_text (ffebld_symter (left_symter));
2102 char_name = "[expr?]";
2104 ffecom_char_args_ (&item, length, ffebld_left (expr));
2106 if (item == error_mark_node || *length == error_mark_node)
2108 item = *length = error_mark_node;
2112 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2114 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2122 end_tree = ffecom_expr (end);
2123 if (flag_bounds_check)
2124 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2126 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2129 if (end_tree == error_mark_node)
2131 item = *length = error_mark_node;
2140 start_tree = ffecom_expr (start);
2141 if (flag_bounds_check)
2142 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2144 start_tree = convert (ffecom_f2c_ftnlen_type_node,
2147 if (start_tree == error_mark_node)
2149 item = *length = error_mark_node;
2153 start_tree = ffecom_save_tree (start_tree);
2155 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2157 ffecom_2 (MINUS_EXPR,
2158 TREE_TYPE (start_tree),
2160 ffecom_f2c_ftnlen_one_node));
2164 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2165 ffecom_f2c_ftnlen_one_node,
2166 ffecom_2 (MINUS_EXPR,
2167 ffecom_f2c_ftnlen_type_node,
2173 end_tree = ffecom_expr (end);
2174 if (flag_bounds_check)
2175 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2177 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2180 if (end_tree == error_mark_node)
2182 item = *length = error_mark_node;
2186 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2187 ffecom_f2c_ftnlen_one_node,
2188 ffecom_2 (MINUS_EXPR,
2189 ffecom_f2c_ftnlen_type_node,
2190 end_tree, start_tree));
2196 case FFEBLD_opFUNCREF:
2198 ffesymbol s = ffebld_symter (ffebld_left (expr));
2201 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2204 if (size == FFETARGET_charactersizeNONE)
2205 /* ~~Kludge alert! This should someday be fixed. */
2208 *length = build_int_2 (size, 0);
2209 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2211 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2212 == FFEINFO_whereINTRINSIC)
2216 /* Invocation of an intrinsic returning CHARACTER*1. */
2217 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2221 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2222 assert (ix != FFECOM_gfrt);
2223 item = ffecom_gfrt_tree_ (ix);
2228 item = ffesymbol_hook (s).decl_tree;
2229 if (item == NULL_TREE)
2231 s = ffecom_sym_transform_ (s);
2232 item = ffesymbol_hook (s).decl_tree;
2234 if (item == error_mark_node)
2236 item = *length = error_mark_node;
2240 if (!ffesymbol_hook (s).addr)
2241 item = ffecom_1_fn (item);
2245 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2247 tempvar = ffebld_nonter_hook (expr);
2250 tempvar = ffecom_1 (ADDR_EXPR,
2251 build_pointer_type (TREE_TYPE (tempvar)),
2254 args = build_tree_list (NULL_TREE, tempvar);
2256 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
2257 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2260 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2261 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2263 TREE_CHAIN (TREE_CHAIN (args))
2264 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2265 ffebld_right (expr));
2269 TREE_CHAIN (TREE_CHAIN (args))
2270 = ffecom_list_ptr_to_expr (ffebld_right (expr));
2274 item = ffecom_3s (CALL_EXPR,
2275 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2276 item, args, NULL_TREE);
2277 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2282 case FFEBLD_opCONVERT:
2284 ffecom_char_args_ (&item, length, ffebld_left (expr));
2286 if (item == error_mark_node || *length == error_mark_node)
2288 item = *length = error_mark_node;
2292 if ((ffebld_size_known (ffebld_left (expr))
2293 == FFETARGET_charactersizeNONE)
2294 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2295 { /* Possible blank-padding needed, copy into
2302 tempvar = ffecom_make_tempvar (char_type_node,
2303 ffebld_size (expr), -1);
2305 tempvar = ffebld_nonter_hook (expr);
2308 tempvar = ffecom_1 (ADDR_EXPR,
2309 build_pointer_type (TREE_TYPE (tempvar)),
2312 newlen = build_int_2 (ffebld_size (expr), 0);
2313 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2315 args = build_tree_list (NULL_TREE, tempvar);
2316 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2317 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2318 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2319 = build_tree_list (NULL_TREE, *length);
2321 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2322 TREE_SIDE_EFFECTS (item) = 1;
2323 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2328 { /* Just truncate the length. */
2329 *length = build_int_2 (ffebld_size (expr), 0);
2330 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2335 assert ("bad op for single char arg expr" == NULL);
2344 /* Check the size of the type to be sure it doesn't overflow the
2345 "portable" capacities of the compiler back end. `dummy' types
2346 can generally overflow the normal sizes as long as the computations
2347 themselves don't overflow. A particular target of the back end
2348 must still enforce its size requirements, though, and the back
2349 end takes care of this in stor-layout.c. */
2351 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2353 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2355 if (TREE_CODE (type) == ERROR_MARK)
2358 if (TYPE_SIZE (type) == NULL_TREE)
2361 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2364 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2365 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2366 || TREE_OVERFLOW (TYPE_SIZE (type)))))
2368 ffebad_start (FFEBAD_ARRAY_LARGE);
2369 ffebad_string (ffesymbol_text (s));
2370 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2373 return error_mark_node;
2380 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2381 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2382 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2386 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2388 ffetargetCharacterSize sz = ffesymbol_size (s);
2393 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2394 tlen = NULL_TREE; /* A statement function, no length passed. */
2397 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2398 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2399 ffesymbol_text (s));
2401 tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2402 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2404 DECL_ARTIFICIAL (tlen) = 1;
2408 if (sz == FFETARGET_charactersizeNONE)
2410 assert (tlen != NULL_TREE);
2411 highval = variable_size (tlen);
2415 highval = build_int_2 (sz, 0);
2416 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2419 type = build_array_type (type,
2420 build_range_type (ffecom_f2c_ftnlen_type_node,
2421 ffecom_f2c_ftnlen_one_node,
2429 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2431 ffecomConcatList_ catlist;
2432 ffebld expr; // expr of CHARACTER basictype.
2433 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2434 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2436 Scans expr for character subexpressions, updates and returns catlist
2439 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2440 static ffecomConcatList_
2441 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2442 ffetargetCharacterSize max)
2444 ffetargetCharacterSize sz;
2446 recurse: /* :::::::::::::::::::: */
2451 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2452 return catlist; /* Don't append any more items. */
2454 switch (ffebld_op (expr))
2456 case FFEBLD_opCONTER:
2457 case FFEBLD_opSYMTER:
2458 case FFEBLD_opARRAYREF:
2459 case FFEBLD_opFUNCREF:
2460 case FFEBLD_opSUBSTR:
2461 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2462 if they don't need to preserve it. */
2463 if (catlist.count == catlist.max)
2464 { /* Make a (larger) list. */
2468 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2469 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2470 newmax * sizeof (newx[0]));
2471 if (catlist.max != 0)
2473 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2474 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2475 catlist.max * sizeof (newx[0]));
2477 catlist.max = newmax;
2478 catlist.exprs = newx;
2480 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2481 catlist.minlen += sz;
2483 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2484 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2485 catlist.maxlen = sz;
2487 catlist.maxlen += sz;
2488 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2489 { /* This item overlaps (or is beyond) the end
2490 of the destination. */
2491 switch (ffebld_op (expr))
2493 case FFEBLD_opCONTER:
2494 case FFEBLD_opSYMTER:
2495 case FFEBLD_opARRAYREF:
2496 case FFEBLD_opFUNCREF:
2497 case FFEBLD_opSUBSTR:
2498 /* ~~Do useful truncations here. */
2502 assert ("op changed or inconsistent switches!" == NULL);
2506 catlist.exprs[catlist.count++] = expr;
2509 case FFEBLD_opPAREN:
2510 expr = ffebld_left (expr);
2511 goto recurse; /* :::::::::::::::::::: */
2513 case FFEBLD_opCONCATENATE:
2514 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2515 expr = ffebld_right (expr);
2516 goto recurse; /* :::::::::::::::::::: */
2518 #if 0 /* Breaks passing small actual arg to larger
2519 dummy arg of sfunc */
2520 case FFEBLD_opCONVERT:
2521 expr = ffebld_left (expr);
2523 ffetargetCharacterSize cmax;
2525 cmax = catlist.len + ffebld_size_known (expr);
2527 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2530 goto recurse; /* :::::::::::::::::::: */
2537 assert ("bad op in _gather_" == NULL);
2543 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2545 ffecomConcatList_ catlist;
2546 ffecom_concat_list_kill_(catlist);
2548 Anything allocated within the list info is deallocated. */
2550 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2552 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2554 if (catlist.max != 0)
2555 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2556 catlist.max * sizeof (catlist.exprs[0]));
2560 /* Make list of concatenated string exprs.
2562 Returns a flattened list of concatenated subexpressions given a
2563 tree of such expressions. */
2565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2566 static ffecomConcatList_
2567 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2569 ffecomConcatList_ catlist;
2571 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2572 return ffecom_concat_list_gather_ (catlist, expr, max);
2577 /* Provide some kind of useful info on member of aggregate area,
2578 since current g77/gcc technology does not provide debug info
2579 on these members. */
2581 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2583 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2584 tree member_type UNUSED, ffetargetOffset offset)
2594 for (type_id = member_type;
2595 TREE_CODE (type_id) != IDENTIFIER_NODE;
2598 switch (TREE_CODE (type_id))
2602 type_id = TYPE_NAME (type_id);
2607 type_id = TREE_TYPE (type_id);
2611 assert ("no IDENTIFIER_NODE for type!" == NULL);
2612 type_id = error_mark_node;
2618 if (ffecom_transform_only_dummies_
2619 || !ffe_is_debug_kludge ())
2620 return; /* Can't do this yet, maybe later. */
2623 + strlen (aggr_type)
2624 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2626 + IDENTIFIER_LENGTH (type_id);
2629 if (((size_t) len) >= ARRAY_SIZE (space))
2630 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2634 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2636 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2639 value = build_string (len, buff);
2641 = build_type_variant (build_array_type (char_type_node,
2645 build_int_2 (strlen (buff), 0))),
2647 decl = build_decl (VAR_DECL,
2648 ffecom_get_identifier_ (ffesymbol_text (member)),
2650 TREE_CONSTANT (decl) = 1;
2651 TREE_STATIC (decl) = 1;
2652 DECL_INITIAL (decl) = error_mark_node;
2653 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2654 decl = start_decl (decl, FALSE);
2655 finish_decl (decl, value, FALSE);
2657 if (buff != &space[0])
2658 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2662 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2664 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2665 int i; // entry# for this entrypoint (used by master fn)
2666 ffecom_do_entrypoint_(s,i);
2668 Makes a public entry point that calls our private master fn (already
2671 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2673 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2676 tree type; /* Type of function. */
2677 tree multi_retval; /* Var holding return value (union). */
2678 tree result; /* Var holding result. */
2679 ffeinfoBasictype bt;
2683 bool charfunc; /* All entry points return same type
2685 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2686 bool multi; /* Master fn has multiple return types. */
2687 bool altreturning = FALSE; /* This entry point has alternate returns. */
2688 int old_lineno = lineno;
2689 const char *old_input_filename = input_filename;
2691 input_filename = ffesymbol_where_filename (fn);
2692 lineno = ffesymbol_where_filelinenum (fn);
2694 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2696 switch (ffecom_primary_entry_kind_)
2698 case FFEINFO_kindFUNCTION:
2700 /* Determine actual return type for function. */
2702 gt = FFEGLOBAL_typeFUNC;
2703 bt = ffesymbol_basictype (fn);
2704 kt = ffesymbol_kindtype (fn);
2705 if (bt == FFEINFO_basictypeNONE)
2707 ffeimplic_establish_symbol (fn);
2708 if (ffesymbol_funcresult (fn) != NULL)
2709 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2710 bt = ffesymbol_basictype (fn);
2711 kt = ffesymbol_kindtype (fn);
2714 if (bt == FFEINFO_basictypeCHARACTER)
2715 charfunc = TRUE, cmplxfunc = FALSE;
2716 else if ((bt == FFEINFO_basictypeCOMPLEX)
2717 && ffesymbol_is_f2c (fn))
2718 charfunc = FALSE, cmplxfunc = TRUE;
2720 charfunc = cmplxfunc = FALSE;
2723 type = ffecom_tree_fun_type_void;
2724 else if (ffesymbol_is_f2c (fn))
2725 type = ffecom_tree_fun_type[bt][kt];
2727 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2729 if ((type == NULL_TREE)
2730 || (TREE_TYPE (type) == NULL_TREE))
2731 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2733 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2736 case FFEINFO_kindSUBROUTINE:
2737 gt = FFEGLOBAL_typeSUBR;
2738 bt = FFEINFO_basictypeNONE;
2739 kt = FFEINFO_kindtypeNONE;
2740 if (ffecom_is_altreturning_)
2741 { /* Am _I_ altreturning? */
2742 for (item = ffesymbol_dummyargs (fn);
2744 item = ffebld_trail (item))
2746 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2748 altreturning = TRUE;
2753 type = ffecom_tree_subr_type;
2755 type = ffecom_tree_fun_type_void;
2758 type = ffecom_tree_fun_type_void;
2765 assert ("say what??" == NULL);
2767 case FFEINFO_kindANY:
2768 gt = FFEGLOBAL_typeANY;
2769 bt = FFEINFO_basictypeNONE;
2770 kt = FFEINFO_kindtypeNONE;
2771 type = error_mark_node;
2778 /* build_decl uses the current lineno and input_filename to set the decl
2779 source info. So, I've putzed with ffestd and ffeste code to update that
2780 source info to point to the appropriate statement just before calling
2781 ffecom_do_entrypoint (which calls this fn). */
2783 start_function (ffecom_get_external_identifier_ (fn),
2785 0, /* nested/inline */
2786 1); /* TREE_PUBLIC */
2788 if (((g = ffesymbol_global (fn)) != NULL)
2789 && ((ffeglobal_type (g) == gt)
2790 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2792 ffeglobal_set_hook (g, current_function_decl);
2795 /* Reset args in master arg list so they get retransitioned. */
2797 for (item = ffecom_master_arglist_;
2799 item = ffebld_trail (item))
2804 arg = ffebld_head (item);
2805 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2806 continue; /* Alternate return or some such thing. */
2807 s = ffebld_symter (arg);
2808 ffesymbol_hook (s).decl_tree = NULL_TREE;
2809 ffesymbol_hook (s).length_tree = NULL_TREE;
2812 /* Build dummy arg list for this entry point. */
2814 if (charfunc || cmplxfunc)
2815 { /* Prepend arg for where result goes. */
2820 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2822 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2824 result = ffecom_get_invented_identifier ("__g77_%s", "result");
2826 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2829 length = ffecom_char_enhance_arg_ (&type, fn);
2831 length = NULL_TREE; /* Not ref'd if !charfunc. */
2833 type = build_pointer_type (type);
2834 result = build_decl (PARM_DECL, result, type);
2836 push_parm_decl (result);
2837 ffecom_func_result_ = result;
2841 push_parm_decl (length);
2842 ffecom_func_length_ = length;
2846 result = DECL_RESULT (current_function_decl);
2848 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2850 store_parm_decls (0);
2852 ffecom_start_compstmt ();
2853 /* Disallow temp vars at this level. */
2854 current_binding_level->prep_state = 2;
2856 /* Make local var to hold return type for multi-type master fn. */
2860 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2862 multi_retval = build_decl (VAR_DECL, multi_retval,
2863 ffecom_multi_type_node_);
2864 multi_retval = start_decl (multi_retval, FALSE);
2865 finish_decl (multi_retval, NULL_TREE, FALSE);
2868 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2870 /* Here we emit the actual code for the entry point. */
2876 tree arglist = NULL_TREE;
2877 tree *plist = &arglist;
2883 /* Prepare actual arg list based on master arg list. */
2885 for (list = ffecom_master_arglist_;
2887 list = ffebld_trail (list))
2889 arg = ffebld_head (list);
2890 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2892 s = ffebld_symter (arg);
2893 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2894 || ffesymbol_hook (s).decl_tree == error_mark_node)
2895 actarg = null_pointer_node; /* We don't have this arg. */
2897 actarg = ffesymbol_hook (s).decl_tree;
2898 *plist = build_tree_list (NULL_TREE, actarg);
2899 plist = &TREE_CHAIN (*plist);
2902 /* This code appends the length arguments for character
2903 variables/arrays. */
2905 for (list = ffecom_master_arglist_;
2907 list = ffebld_trail (list))
2909 arg = ffebld_head (list);
2910 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2912 s = ffebld_symter (arg);
2913 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2914 continue; /* Only looking for CHARACTER arguments. */
2915 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2916 continue; /* Only looking for variables and arrays. */
2917 if (ffesymbol_hook (s).length_tree == NULL_TREE
2918 || ffesymbol_hook (s).length_tree == error_mark_node)
2919 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2921 actarg = ffesymbol_hook (s).length_tree;
2922 *plist = build_tree_list (NULL_TREE, actarg);
2923 plist = &TREE_CHAIN (*plist);
2926 /* Prepend character-value return info to actual arg list. */
2930 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2931 TREE_CHAIN (prepend)
2932 = build_tree_list (NULL_TREE, ffecom_func_length_);
2933 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2937 /* Prepend multi-type return value to actual arg list. */
2942 = build_tree_list (NULL_TREE,
2943 ffecom_1 (ADDR_EXPR,
2944 build_pointer_type (TREE_TYPE (multi_retval)),
2946 TREE_CHAIN (prepend) = arglist;
2950 /* Prepend my entry-point number to the actual arg list. */
2952 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2953 TREE_CHAIN (prepend) = arglist;
2956 /* Build the call to the master function. */
2958 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2959 call = ffecom_3s (CALL_EXPR,
2960 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2961 master_fn, arglist, NULL_TREE);
2963 /* Decide whether the master function is a function or subroutine, and
2964 handle the return value for my entry point. */
2966 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2969 expand_expr_stmt (call);
2970 expand_null_return ();
2972 else if (multi && cmplxfunc)
2974 expand_expr_stmt (call);
2976 = ffecom_1 (INDIRECT_REF,
2977 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2979 result = ffecom_modify (NULL_TREE, result,
2980 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2982 ffecom_multi_fields_[bt][kt]));
2983 expand_expr_stmt (result);
2984 expand_null_return ();
2988 expand_expr_stmt (call);
2990 = ffecom_modify (NULL_TREE, result,
2991 convert (TREE_TYPE (result),
2992 ffecom_2 (COMPONENT_REF,
2993 ffecom_tree_type[bt][kt],
2995 ffecom_multi_fields_[bt][kt])));
2996 expand_return (result);
3001 = ffecom_1 (INDIRECT_REF,
3002 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3004 result = ffecom_modify (NULL_TREE, result, call);
3005 expand_expr_stmt (result);
3006 expand_null_return ();
3010 result = ffecom_modify (NULL_TREE,
3012 convert (TREE_TYPE (result),
3014 expand_return (result);
3018 ffecom_end_compstmt ();
3020 finish_function (0);
3022 lineno = old_lineno;
3023 input_filename = old_input_filename;
3025 ffecom_doing_entry_ = FALSE;
3029 /* Transform expr into gcc tree with possible destination
3031 Recursive descent on expr while making corresponding tree nodes and
3032 attaching type info and such. If destination supplied and compatible
3033 with temporary that would be made in certain cases, temporary isn't
3034 made, destination used instead, and dest_used flag set TRUE. */
3036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3038 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3039 bool *dest_used, bool assignp, bool widenp)
3044 ffeinfoBasictype bt;
3047 tree dt; /* decl_tree for an ffesymbol. */
3048 tree tree_type, tree_type_x;
3051 enum tree_code code;
3053 assert (expr != NULL);
3055 if (dest_used != NULL)
3058 bt = ffeinfo_basictype (ffebld_info (expr));
3059 kt = ffeinfo_kindtype (ffebld_info (expr));
3060 tree_type = ffecom_tree_type[bt][kt];
3062 /* Widen integral arithmetic as desired while preserving signedness. */
3063 tree_type_x = NULL_TREE;
3064 if (widenp && tree_type
3065 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3066 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3067 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3069 switch (ffebld_op (expr))
3071 case FFEBLD_opACCTER:
3074 ffebit bits = ffebld_accter_bits (expr);
3075 ffetargetOffset source_offset = 0;
3076 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3079 assert (dest_offset == 0
3080 || (bt == FFEINFO_basictypeCHARACTER
3081 && kt == FFEINFO_kindtypeCHARACTER1));
3086 ffebldConstantUnion cu;
3089 ffebldConstantArray ca = ffebld_accter (expr);
3091 ffebit_test (bits, source_offset, &value, &length);
3097 for (i = 0; i < length; ++i)
3099 cu = ffebld_constantarray_get (ca, bt, kt,
3102 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3105 && dest_offset != 0)
3106 purpose = build_int_2 (dest_offset, 0);
3108 purpose = NULL_TREE;
3110 if (list == NULL_TREE)
3111 list = item = build_tree_list (purpose, t);
3114 TREE_CHAIN (item) = build_tree_list (purpose, t);
3115 item = TREE_CHAIN (item);
3119 source_offset += length;
3120 dest_offset += length;
3124 item = build_int_2 ((ffebld_accter_size (expr)
3125 + ffebld_accter_pad (expr)) - 1, 0);
3126 ffebit_kill (ffebld_accter_bits (expr));
3127 TREE_TYPE (item) = ffecom_integer_type_node;
3131 build_range_type (ffecom_integer_type_node,
3132 ffecom_integer_zero_node,
3134 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3135 TREE_CONSTANT (list) = 1;
3136 TREE_STATIC (list) = 1;
3139 case FFEBLD_opARRTER:
3144 if (ffebld_arrter_pad (expr) == 0)
3148 assert (bt == FFEINFO_basictypeCHARACTER
3149 && kt == FFEINFO_kindtypeCHARACTER1);
3151 /* Becomes PURPOSE first time through loop. */
3152 item = build_int_2 (ffebld_arrter_pad (expr), 0);
3155 for (i = 0; i < ffebld_arrter_size (expr); ++i)
3157 ffebldConstantUnion cu
3158 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3160 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3162 if (list == NULL_TREE)
3163 /* Assume item is PURPOSE first time through loop. */
3164 list = item = build_tree_list (item, t);
3167 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3168 item = TREE_CHAIN (item);
3173 item = build_int_2 ((ffebld_arrter_size (expr)
3174 + ffebld_arrter_pad (expr)) - 1, 0);
3175 TREE_TYPE (item) = ffecom_integer_type_node;
3179 build_range_type (ffecom_integer_type_node,
3180 ffecom_integer_zero_node,
3182 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3183 TREE_CONSTANT (list) = 1;
3184 TREE_STATIC (list) = 1;
3187 case FFEBLD_opCONTER:
3188 assert (ffebld_conter_pad (expr) == 0);
3190 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3194 case FFEBLD_opSYMTER:
3195 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3196 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3197 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
3198 s = ffebld_symter (expr);
3199 t = ffesymbol_hook (s).decl_tree;
3202 { /* ASSIGN'ed-label expr. */
3203 if (ffe_is_ugly_assign ())
3205 /* User explicitly wants ASSIGN'ed variables to be at the same
3206 memory address as the variables when used in non-ASSIGN
3207 contexts. That can make old, arcane, non-standard code
3208 work, but don't try to do it when a pointer wouldn't fit
3209 in the normal variable (take other approach, and warn,
3214 s = ffecom_sym_transform_ (s);
3215 t = ffesymbol_hook (s).decl_tree;
3216 assert (t != NULL_TREE);
3219 if (t == error_mark_node)
3222 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3223 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3225 if (ffesymbol_hook (s).addr)
3226 t = ffecom_1 (INDIRECT_REF,
3227 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3231 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3233 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3234 FFEBAD_severityWARNING);
3235 ffebad_string (ffesymbol_text (s));
3236 ffebad_here (0, ffesymbol_where_line (s),
3237 ffesymbol_where_column (s));
3242 /* Don't use the normal variable's tree for ASSIGN, though mark
3243 it as in the system header (housekeeping). Use an explicit,
3244 specially created sibling that is known to be wide enough
3245 to hold pointers to labels. */
3248 && TREE_CODE (t) == VAR_DECL)
3249 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
3251 t = ffesymbol_hook (s).assign_tree;
3254 s = ffecom_sym_transform_assign_ (s);
3255 t = ffesymbol_hook (s).assign_tree;
3256 assert (t != NULL_TREE);
3263 s = ffecom_sym_transform_ (s);
3264 t = ffesymbol_hook (s).decl_tree;
3265 assert (t != NULL_TREE);
3267 if (ffesymbol_hook (s).addr)
3268 t = ffecom_1 (INDIRECT_REF,
3269 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3273 case FFEBLD_opARRAYREF:
3274 return ffecom_arrayref_ (NULL_TREE, expr, 0);
3276 case FFEBLD_opUPLUS:
3277 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3278 return ffecom_1 (NOP_EXPR, tree_type, left);
3280 case FFEBLD_opPAREN:
3281 /* ~~~Make sure Fortran rules respected here */
3282 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3283 return ffecom_1 (NOP_EXPR, tree_type, left);
3285 case FFEBLD_opUMINUS:
3286 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3289 tree_type = tree_type_x;
3290 left = convert (tree_type, left);
3292 return ffecom_1 (NEGATE_EXPR, tree_type, left);
3295 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3296 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3299 tree_type = tree_type_x;
3300 left = convert (tree_type, left);
3301 right = convert (tree_type, right);
3303 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3305 case FFEBLD_opSUBTRACT:
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 (MINUS_EXPR, tree_type, left, right);
3316 case FFEBLD_opMULTIPLY:
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 (MULT_EXPR, tree_type, left, right);
3327 case FFEBLD_opDIVIDE:
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_tree_divide_ (tree_type, left, right,
3337 dest_tree, dest, dest_used,
3338 ffebld_nonter_hook (expr));
3340 case FFEBLD_opPOWER:
3342 ffebld left = ffebld_left (expr);
3343 ffebld right = ffebld_right (expr);
3345 ffeinfoKindtype rtkt;
3346 ffeinfoKindtype ltkt;
3349 switch (ffeinfo_basictype (ffebld_info (right)))
3352 case FFEINFO_basictypeINTEGER:
3355 item = ffecom_expr_power_integer_ (expr);
3356 if (item != NULL_TREE)
3360 rtkt = FFEINFO_kindtypeINTEGER1;
3361 switch (ffeinfo_basictype (ffebld_info (left)))
3363 case FFEINFO_basictypeINTEGER:
3364 if ((ffeinfo_kindtype (ffebld_info (left))
3365 == FFEINFO_kindtypeINTEGER4)
3366 || (ffeinfo_kindtype (ffebld_info (right))
3367 == FFEINFO_kindtypeINTEGER4))
3369 code = FFECOM_gfrtPOW_QQ;
3370 ltkt = FFEINFO_kindtypeINTEGER4;
3371 rtkt = FFEINFO_kindtypeINTEGER4;
3375 code = FFECOM_gfrtPOW_II;
3376 ltkt = FFEINFO_kindtypeINTEGER1;
3380 case FFEINFO_basictypeREAL:
3381 if (ffeinfo_kindtype (ffebld_info (left))
3382 == FFEINFO_kindtypeREAL1)
3384 code = FFECOM_gfrtPOW_RI;
3385 ltkt = FFEINFO_kindtypeREAL1;
3389 code = FFECOM_gfrtPOW_DI;
3390 ltkt = FFEINFO_kindtypeREAL2;
3394 case FFEINFO_basictypeCOMPLEX:
3395 if (ffeinfo_kindtype (ffebld_info (left))
3396 == FFEINFO_kindtypeREAL1)
3398 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3399 ltkt = FFEINFO_kindtypeREAL1;
3403 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3404 ltkt = FFEINFO_kindtypeREAL2;
3409 assert ("bad pow_*i" == NULL);
3410 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3411 ltkt = FFEINFO_kindtypeREAL1;
3414 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3415 left = ffeexpr_convert (left, NULL, NULL,
3416 ffeinfo_basictype (ffebld_info (left)),
3418 FFETARGET_charactersizeNONE,
3419 FFEEXPR_contextLET);
3420 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3421 right = ffeexpr_convert (right, NULL, NULL,
3422 FFEINFO_basictypeINTEGER,
3424 FFETARGET_charactersizeNONE,
3425 FFEEXPR_contextLET);
3428 case FFEINFO_basictypeREAL:
3429 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3430 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3431 FFEINFO_kindtypeREALDOUBLE, 0,
3432 FFETARGET_charactersizeNONE,
3433 FFEEXPR_contextLET);
3434 if (ffeinfo_kindtype (ffebld_info (right))
3435 == FFEINFO_kindtypeREAL1)
3436 right = ffeexpr_convert (right, NULL, NULL,
3437 FFEINFO_basictypeREAL,
3438 FFEINFO_kindtypeREALDOUBLE, 0,
3439 FFETARGET_charactersizeNONE,
3440 FFEEXPR_contextLET);
3441 /* We used to call FFECOM_gfrtPOW_DD here,
3442 which passes arguments by reference. */
3443 code = FFECOM_gfrtL_POW;
3444 /* Pass arguments by value. */
3448 case FFEINFO_basictypeCOMPLEX:
3449 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3450 left = ffeexpr_convert (left, NULL, NULL,
3451 FFEINFO_basictypeCOMPLEX,
3452 FFEINFO_kindtypeREALDOUBLE, 0,
3453 FFETARGET_charactersizeNONE,
3454 FFEEXPR_contextLET);
3455 if (ffeinfo_kindtype (ffebld_info (right))
3456 == FFEINFO_kindtypeREAL1)
3457 right = ffeexpr_convert (right, NULL, NULL,
3458 FFEINFO_basictypeCOMPLEX,
3459 FFEINFO_kindtypeREALDOUBLE, 0,
3460 FFETARGET_charactersizeNONE,
3461 FFEEXPR_contextLET);
3462 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3463 ref = TRUE; /* Pass arguments by reference. */
3467 assert ("bad pow_x*" == NULL);
3468 code = FFECOM_gfrtPOW_II;
3471 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3472 ffecom_gfrt_kindtype (code),
3473 (ffe_is_f2c_library ()
3474 && ffecom_gfrt_complex_[code]),
3475 tree_type, left, right,
3476 dest_tree, dest, dest_used,
3477 NULL_TREE, FALSE, ref,
3478 ffebld_nonter_hook (expr));
3484 case FFEINFO_basictypeLOGICAL:
3485 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3486 return convert (tree_type, item);
3488 case FFEINFO_basictypeINTEGER:
3489 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3490 ffecom_expr (ffebld_left (expr)));
3493 assert ("NOT bad basictype" == NULL);
3495 case FFEINFO_basictypeANY:
3496 return error_mark_node;
3500 case FFEBLD_opFUNCREF:
3501 assert (ffeinfo_basictype (ffebld_info (expr))
3502 != FFEINFO_basictypeCHARACTER);
3504 case FFEBLD_opSUBRREF:
3505 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3506 == FFEINFO_whereINTRINSIC)
3507 { /* Invocation of an intrinsic. */
3508 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3512 s = ffebld_symter (ffebld_left (expr));
3513 dt = ffesymbol_hook (s).decl_tree;
3514 if (dt == NULL_TREE)
3516 s = ffecom_sym_transform_ (s);
3517 dt = ffesymbol_hook (s).decl_tree;
3519 if (dt == error_mark_node)
3522 if (ffesymbol_hook (s).addr)
3525 item = ffecom_1_fn (dt);
3527 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3528 args = ffecom_list_expr (ffebld_right (expr));
3530 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3532 if (args == error_mark_node)
3533 return error_mark_node;
3535 item = ffecom_call_ (item, kt,
3536 ffesymbol_is_f2c (s)
3537 && (bt == FFEINFO_basictypeCOMPLEX)
3538 && (ffesymbol_where (s)
3539 != FFEINFO_whereCONSTANT),
3542 dest_tree, dest, dest_used,
3543 error_mark_node, FALSE,
3544 ffebld_nonter_hook (expr));
3545 TREE_SIDE_EFFECTS (item) = 1;
3551 case FFEINFO_basictypeLOGICAL:
3553 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3554 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3555 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3556 return convert (tree_type, item);
3558 case FFEINFO_basictypeINTEGER:
3559 return ffecom_2 (BIT_AND_EXPR, tree_type,
3560 ffecom_expr (ffebld_left (expr)),
3561 ffecom_expr (ffebld_right (expr)));
3564 assert ("AND bad basictype" == NULL);
3566 case FFEINFO_basictypeANY:
3567 return error_mark_node;
3574 case FFEINFO_basictypeLOGICAL:
3576 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3577 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3578 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3579 return convert (tree_type, item);
3581 case FFEINFO_basictypeINTEGER:
3582 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3583 ffecom_expr (ffebld_left (expr)),
3584 ffecom_expr (ffebld_right (expr)));
3587 assert ("OR bad basictype" == NULL);
3589 case FFEINFO_basictypeANY:
3590 return error_mark_node;
3598 case FFEINFO_basictypeLOGICAL:
3600 = ffecom_2 (NE_EXPR, integer_type_node,
3601 ffecom_expr (ffebld_left (expr)),
3602 ffecom_expr (ffebld_right (expr)));
3603 return convert (tree_type, ffecom_truth_value (item));
3605 case FFEINFO_basictypeINTEGER:
3606 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3607 ffecom_expr (ffebld_left (expr)),
3608 ffecom_expr (ffebld_right (expr)));
3611 assert ("XOR/NEQV bad basictype" == NULL);
3613 case FFEINFO_basictypeANY:
3614 return error_mark_node;
3621 case FFEINFO_basictypeLOGICAL:
3623 = ffecom_2 (EQ_EXPR, integer_type_node,
3624 ffecom_expr (ffebld_left (expr)),
3625 ffecom_expr (ffebld_right (expr)));
3626 return convert (tree_type, ffecom_truth_value (item));
3628 case FFEINFO_basictypeINTEGER:
3630 ffecom_1 (BIT_NOT_EXPR, tree_type,
3631 ffecom_2 (BIT_XOR_EXPR, tree_type,
3632 ffecom_expr (ffebld_left (expr)),
3633 ffecom_expr (ffebld_right (expr))));
3636 assert ("EQV bad basictype" == NULL);
3638 case FFEINFO_basictypeANY:
3639 return error_mark_node;
3643 case FFEBLD_opCONVERT:
3644 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3645 return error_mark_node;
3649 case FFEINFO_basictypeLOGICAL:
3650 case FFEINFO_basictypeINTEGER:
3651 case FFEINFO_basictypeREAL:
3652 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3654 case FFEINFO_basictypeCOMPLEX:
3655 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3657 case FFEINFO_basictypeINTEGER:
3658 case FFEINFO_basictypeLOGICAL:
3659 case FFEINFO_basictypeREAL:
3660 item = ffecom_expr (ffebld_left (expr));
3661 if (item == error_mark_node)
3662 return error_mark_node;
3663 /* convert() takes care of converting to the subtype first,
3664 at least in gcc-2.7.2. */
3665 item = convert (tree_type, item);
3668 case FFEINFO_basictypeCOMPLEX:
3669 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3672 assert ("CONVERT COMPLEX bad basictype" == NULL);
3674 case FFEINFO_basictypeANY:
3675 return error_mark_node;
3680 assert ("CONVERT bad basictype" == NULL);
3682 case FFEINFO_basictypeANY:
3683 return error_mark_node;
3689 goto relational; /* :::::::::::::::::::: */
3693 goto relational; /* :::::::::::::::::::: */
3697 goto relational; /* :::::::::::::::::::: */
3701 goto relational; /* :::::::::::::::::::: */
3705 goto relational; /* :::::::::::::::::::: */
3710 relational: /* :::::::::::::::::::: */
3711 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3713 case FFEINFO_basictypeLOGICAL:
3714 case FFEINFO_basictypeINTEGER:
3715 case FFEINFO_basictypeREAL:
3716 item = ffecom_2 (code, integer_type_node,
3717 ffecom_expr (ffebld_left (expr)),
3718 ffecom_expr (ffebld_right (expr)));
3719 return convert (tree_type, item);
3721 case FFEINFO_basictypeCOMPLEX:
3722 assert (code == EQ_EXPR || code == NE_EXPR);
3725 tree arg1 = ffecom_expr (ffebld_left (expr));
3726 tree arg2 = ffecom_expr (ffebld_right (expr));
3728 if (arg1 == error_mark_node || arg2 == error_mark_node)
3729 return error_mark_node;
3731 arg1 = ffecom_save_tree (arg1);
3732 arg2 = ffecom_save_tree (arg2);
3734 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3736 real_type = TREE_TYPE (TREE_TYPE (arg1));
3737 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3741 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3742 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3746 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3747 ffecom_2 (EQ_EXPR, integer_type_node,
3748 ffecom_1 (REALPART_EXPR, real_type, arg1),
3749 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3750 ffecom_2 (EQ_EXPR, integer_type_node,
3751 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3752 ffecom_1 (IMAGPART_EXPR, real_type,
3754 if (code == EQ_EXPR)
3755 item = ffecom_truth_value (item);
3757 item = ffecom_truth_value_invert (item);
3758 return convert (tree_type, item);
3761 case FFEINFO_basictypeCHARACTER:
3763 ffebld left = ffebld_left (expr);
3764 ffebld right = ffebld_right (expr);
3770 /* f2c run-time functions do the implicit blank-padding for us,
3771 so we don't usually have to implement blank-padding ourselves.
3772 (The exception is when we pass an argument to a separately
3773 compiled statement function -- if we know the arg is not the
3774 same length as the dummy, we must truncate or extend it. If
3775 we "inline" statement functions, that necessity goes away as
3778 Strip off the CONVERT operators that blank-pad. (Truncation by
3779 CONVERT shouldn't happen here, but it can happen in
3782 while (ffebld_op (left) == FFEBLD_opCONVERT)
3783 left = ffebld_left (left);
3784 while (ffebld_op (right) == FFEBLD_opCONVERT)
3785 right = ffebld_left (right);
3787 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3788 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3790 if (left_tree == error_mark_node || left_length == error_mark_node
3791 || right_tree == error_mark_node
3792 || right_length == error_mark_node)
3793 return error_mark_node;
3795 if ((ffebld_size_known (left) == 1)
3796 && (ffebld_size_known (right) == 1))
3799 = ffecom_1 (INDIRECT_REF,
3800 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3803 = ffecom_1 (INDIRECT_REF,
3804 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3808 = ffecom_2 (code, integer_type_node,
3809 ffecom_2 (ARRAY_REF,
3810 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3813 ffecom_2 (ARRAY_REF,
3814 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3820 item = build_tree_list (NULL_TREE, left_tree);
3821 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3822 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3824 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3825 = build_tree_list (NULL_TREE, right_length);
3826 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3827 item = ffecom_2 (code, integer_type_node,
3829 convert (TREE_TYPE (item),
3830 integer_zero_node));
3832 item = convert (tree_type, item);
3838 assert ("relational bad basictype" == NULL);
3840 case FFEINFO_basictypeANY:
3841 return error_mark_node;
3845 case FFEBLD_opPERCENT_LOC:
3846 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3847 return convert (tree_type, item);
3851 case FFEBLD_opBOUNDS:
3852 case FFEBLD_opREPEAT:
3853 case FFEBLD_opLABTER:
3854 case FFEBLD_opLABTOK:
3855 case FFEBLD_opIMPDO:
3856 case FFEBLD_opCONCATENATE:
3857 case FFEBLD_opSUBSTR:
3859 assert ("bad op" == NULL);
3862 return error_mark_node;
3866 assert ("didn't think anything got here anymore!!" == NULL);
3868 switch (ffebld_arity (expr))
3871 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3872 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3873 if (TREE_OPERAND (item, 0) == error_mark_node
3874 || TREE_OPERAND (item, 1) == error_mark_node)
3875 return error_mark_node;
3879 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3880 if (TREE_OPERAND (item, 0) == error_mark_node)
3881 return error_mark_node;
3893 /* Returns the tree that does the intrinsic invocation.
3895 Note: this function applies only to intrinsics returning
3896 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3901 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3902 ffebld dest, bool *dest_used)
3905 tree saved_expr1; /* For those who need it. */
3906 tree saved_expr2; /* For those who need it. */
3907 ffeinfoBasictype bt;
3911 tree real_type; /* REAL type corresponding to COMPLEX. */
3913 ffebld list = ffebld_right (expr); /* List of (some) args. */
3914 ffebld arg1; /* For handy reference. */
3917 ffeintrinImp codegen_imp;
3920 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3922 if (dest_used != NULL)
3925 bt = ffeinfo_basictype (ffebld_info (expr));
3926 kt = ffeinfo_kindtype (ffebld_info (expr));
3927 tree_type = ffecom_tree_type[bt][kt];
3931 arg1 = ffebld_head (list);
3932 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3933 return error_mark_node;
3934 if ((list = ffebld_trail (list)) != NULL)
3936 arg2 = ffebld_head (list);
3937 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3938 return error_mark_node;
3939 if ((list = ffebld_trail (list)) != NULL)
3941 arg3 = ffebld_head (list);
3942 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3943 return error_mark_node;
3952 arg1 = arg2 = arg3 = NULL;
3954 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3955 args. This is used by the MAX/MIN expansions. */
3958 arg1_type = ffecom_tree_type
3959 [ffeinfo_basictype (ffebld_info (arg1))]
3960 [ffeinfo_kindtype (ffebld_info (arg1))];
3962 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3965 /* There are several ways for each of the cases in the following switch
3966 statements to exit (from simplest to use to most complicated):
3968 break; (when expr_tree == NULL)
3970 A standard call is made to the specific intrinsic just as if it had been
3971 passed in as a dummy procedure and called as any old procedure. This
3972 method can produce slower code but in some cases it's the easiest way for
3973 now. However, if a (presumably faster) direct call is available,
3974 that is used, so this is the easiest way in many more cases now.
3976 gfrt = FFECOM_gfrtWHATEVER;
3979 gfrt contains the gfrt index of a library function to call, passing the
3980 argument(s) by value rather than by reference. Used when a more
3981 careful choice of library function is needed than that provided
3982 by the vanilla `break;'.
3986 The expr_tree has been completely set up and is ready to be returned
3987 as is. No further actions are taken. Use this when the tree is not
3988 in the simple form for one of the arity_n labels. */
3990 /* For info on how the switch statement cases were written, see the files
3991 enclosed in comments below the switch statement. */
3993 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3994 gfrt = ffeintrin_gfrt_direct (codegen_imp);
3995 if (gfrt == FFECOM_gfrt)
3996 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3998 switch (codegen_imp)
4000 case FFEINTRIN_impABS:
4001 case FFEINTRIN_impCABS:
4002 case FFEINTRIN_impCDABS:
4003 case FFEINTRIN_impDABS:
4004 case FFEINTRIN_impIABS:
4005 if (ffeinfo_basictype (ffebld_info (arg1))
4006 == FFEINFO_basictypeCOMPLEX)
4008 if (kt == FFEINFO_kindtypeREAL1)
4009 gfrt = FFECOM_gfrtCABS;
4010 else if (kt == FFEINFO_kindtypeREAL2)
4011 gfrt = FFECOM_gfrtCDABS;
4014 return ffecom_1 (ABS_EXPR, tree_type,
4015 convert (tree_type, ffecom_expr (arg1)));
4017 case FFEINTRIN_impACOS:
4018 case FFEINTRIN_impDACOS:
4021 case FFEINTRIN_impAIMAG:
4022 case FFEINTRIN_impDIMAG:
4023 case FFEINTRIN_impIMAGPART:
4024 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4025 arg1_type = TREE_TYPE (arg1_type);
4027 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4031 ffecom_1 (IMAGPART_EXPR, arg1_type,
4032 ffecom_expr (arg1)));
4034 case FFEINTRIN_impAINT:
4035 case FFEINTRIN_impDINT:
4037 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
4038 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4039 #else /* in the meantime, must use floor to avoid range problems with ints */
4040 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4041 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4044 ffecom_3 (COND_EXPR, double_type_node,
4046 (ffecom_2 (GE_EXPR, integer_type_node,
4049 ffecom_float_zero_))),
4050 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4051 build_tree_list (NULL_TREE,
4052 convert (double_type_node,
4055 ffecom_1 (NEGATE_EXPR, double_type_node,
4056 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4057 build_tree_list (NULL_TREE,
4058 convert (double_type_node,
4059 ffecom_1 (NEGATE_EXPR,
4067 case FFEINTRIN_impANINT:
4068 case FFEINTRIN_impDNINT:
4069 #if 0 /* This way of doing it won't handle real
4070 numbers of large magnitudes. */
4071 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4072 expr_tree = convert (tree_type,
4073 convert (integer_type_node,
4074 ffecom_3 (COND_EXPR, tree_type,
4079 ffecom_float_zero_)),
4080 ffecom_2 (PLUS_EXPR,
4083 ffecom_float_half_),
4084 ffecom_2 (MINUS_EXPR,
4087 ffecom_float_half_))));
4089 #else /* So we instead call floor. */
4090 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4091 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4094 ffecom_3 (COND_EXPR, double_type_node,
4096 (ffecom_2 (GE_EXPR, integer_type_node,
4099 ffecom_float_zero_))),
4100 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4101 build_tree_list (NULL_TREE,
4102 convert (double_type_node,
4103 ffecom_2 (PLUS_EXPR,
4107 ffecom_float_half_)))),
4109 ffecom_1 (NEGATE_EXPR, double_type_node,
4110 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4111 build_tree_list (NULL_TREE,
4112 convert (double_type_node,
4113 ffecom_2 (MINUS_EXPR,
4116 ffecom_float_half_),
4123 case FFEINTRIN_impASIN:
4124 case FFEINTRIN_impDASIN:
4125 case FFEINTRIN_impATAN:
4126 case FFEINTRIN_impDATAN:
4127 case FFEINTRIN_impATAN2:
4128 case FFEINTRIN_impDATAN2:
4131 case FFEINTRIN_impCHAR:
4132 case FFEINTRIN_impACHAR:
4134 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4136 tempvar = ffebld_nonter_hook (expr);
4140 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4142 expr_tree = ffecom_modify (tmv,
4143 ffecom_2 (ARRAY_REF, tmv, tempvar,
4145 convert (tmv, ffecom_expr (arg1)));
4147 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4150 expr_tree = ffecom_1 (ADDR_EXPR,
4151 build_pointer_type (TREE_TYPE (expr_tree)),
4155 case FFEINTRIN_impCMPLX:
4156 case FFEINTRIN_impDCMPLX:
4159 convert (tree_type, ffecom_expr (arg1));
4161 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4163 ffecom_2 (COMPLEX_EXPR, tree_type,
4164 convert (real_type, ffecom_expr (arg1)),
4166 ffecom_expr (arg2)));
4168 case FFEINTRIN_impCOMPLEX:
4170 ffecom_2 (COMPLEX_EXPR, tree_type,
4172 ffecom_expr (arg2));
4174 case FFEINTRIN_impCONJG:
4175 case FFEINTRIN_impDCONJG:
4179 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4180 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4182 ffecom_2 (COMPLEX_EXPR, tree_type,
4183 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4184 ffecom_1 (NEGATE_EXPR, real_type,
4185 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4188 case FFEINTRIN_impCOS:
4189 case FFEINTRIN_impCCOS:
4190 case FFEINTRIN_impCDCOS:
4191 case FFEINTRIN_impDCOS:
4192 if (bt == FFEINFO_basictypeCOMPLEX)
4194 if (kt == FFEINFO_kindtypeREAL1)
4195 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
4196 else if (kt == FFEINFO_kindtypeREAL2)
4197 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
4201 case FFEINTRIN_impCOSH:
4202 case FFEINTRIN_impDCOSH:
4205 case FFEINTRIN_impDBLE:
4206 case FFEINTRIN_impDFLOAT:
4207 case FFEINTRIN_impDREAL:
4208 case FFEINTRIN_impFLOAT:
4209 case FFEINTRIN_impIDINT:
4210 case FFEINTRIN_impIFIX:
4211 case FFEINTRIN_impINT2:
4212 case FFEINTRIN_impINT8:
4213 case FFEINTRIN_impINT:
4214 case FFEINTRIN_impLONG:
4215 case FFEINTRIN_impREAL:
4216 case FFEINTRIN_impSHORT:
4217 case FFEINTRIN_impSNGL:
4218 return convert (tree_type, ffecom_expr (arg1));
4220 case FFEINTRIN_impDIM:
4221 case FFEINTRIN_impDDIM:
4222 case FFEINTRIN_impIDIM:
4223 saved_expr1 = ffecom_save_tree (convert (tree_type,
4224 ffecom_expr (arg1)));
4225 saved_expr2 = ffecom_save_tree (convert (tree_type,
4226 ffecom_expr (arg2)));
4228 ffecom_3 (COND_EXPR, tree_type,
4230 (ffecom_2 (GT_EXPR, integer_type_node,
4233 ffecom_2 (MINUS_EXPR, tree_type,
4236 convert (tree_type, ffecom_float_zero_));
4238 case FFEINTRIN_impDPROD:
4240 ffecom_2 (MULT_EXPR, tree_type,
4241 convert (tree_type, ffecom_expr (arg1)),
4242 convert (tree_type, ffecom_expr (arg2)));
4244 case FFEINTRIN_impEXP:
4245 case FFEINTRIN_impCDEXP:
4246 case FFEINTRIN_impCEXP:
4247 case FFEINTRIN_impDEXP:
4248 if (bt == FFEINFO_basictypeCOMPLEX)
4250 if (kt == FFEINFO_kindtypeREAL1)
4251 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
4252 else if (kt == FFEINFO_kindtypeREAL2)
4253 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4257 case FFEINTRIN_impICHAR:
4258 case FFEINTRIN_impIACHAR:
4259 #if 0 /* The simple approach. */
4260 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4262 = ffecom_1 (INDIRECT_REF,
4263 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4266 = ffecom_2 (ARRAY_REF,
4267 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4270 return convert (tree_type, expr_tree);
4271 #else /* The more interesting (and more optimal) approach. */
4272 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4273 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4276 convert (tree_type, integer_zero_node));
4280 case FFEINTRIN_impINDEX:
4283 case FFEINTRIN_impLEN:
4285 break; /* The simple approach. */
4287 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4290 case FFEINTRIN_impLGE:
4291 case FFEINTRIN_impLGT:
4292 case FFEINTRIN_impLLE:
4293 case FFEINTRIN_impLLT:
4296 case FFEINTRIN_impLOG:
4297 case FFEINTRIN_impALOG:
4298 case FFEINTRIN_impCDLOG:
4299 case FFEINTRIN_impCLOG:
4300 case FFEINTRIN_impDLOG:
4301 if (bt == FFEINFO_basictypeCOMPLEX)
4303 if (kt == FFEINFO_kindtypeREAL1)
4304 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4305 else if (kt == FFEINFO_kindtypeREAL2)
4306 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4310 case FFEINTRIN_impLOG10:
4311 case FFEINTRIN_impALOG10:
4312 case FFEINTRIN_impDLOG10:
4313 if (gfrt != FFECOM_gfrt)
4314 break; /* Already picked one, stick with it. */
4316 if (kt == FFEINFO_kindtypeREAL1)
4317 /* We used to call FFECOM_gfrtALOG10 here. */
4318 gfrt = FFECOM_gfrtL_LOG10;
4319 else if (kt == FFEINFO_kindtypeREAL2)
4320 /* We used to call FFECOM_gfrtDLOG10 here. */
4321 gfrt = FFECOM_gfrtL_LOG10;
4324 case FFEINTRIN_impMAX:
4325 case FFEINTRIN_impAMAX0:
4326 case FFEINTRIN_impAMAX1:
4327 case FFEINTRIN_impDMAX1:
4328 case FFEINTRIN_impMAX0:
4329 case FFEINTRIN_impMAX1:
4330 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4331 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4333 arg1_type = tree_type;
4334 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4335 convert (arg1_type, ffecom_expr (arg1)),
4336 convert (arg1_type, ffecom_expr (arg2)));
4337 for (; list != NULL; list = ffebld_trail (list))
4339 if ((ffebld_head (list) == NULL)
4340 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4342 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4345 ffecom_expr (ffebld_head (list))));
4347 return convert (tree_type, expr_tree);
4349 case FFEINTRIN_impMIN:
4350 case FFEINTRIN_impAMIN0:
4351 case FFEINTRIN_impAMIN1:
4352 case FFEINTRIN_impDMIN1:
4353 case FFEINTRIN_impMIN0:
4354 case FFEINTRIN_impMIN1:
4355 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4356 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4358 arg1_type = tree_type;
4359 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4360 convert (arg1_type, ffecom_expr (arg1)),
4361 convert (arg1_type, ffecom_expr (arg2)));
4362 for (; list != NULL; list = ffebld_trail (list))
4364 if ((ffebld_head (list) == NULL)
4365 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4367 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4370 ffecom_expr (ffebld_head (list))));
4372 return convert (tree_type, expr_tree);
4374 case FFEINTRIN_impMOD:
4375 case FFEINTRIN_impAMOD:
4376 case FFEINTRIN_impDMOD:
4377 if (bt != FFEINFO_basictypeREAL)
4378 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4379 convert (tree_type, ffecom_expr (arg1)),
4380 convert (tree_type, ffecom_expr (arg2)));
4382 if (kt == FFEINFO_kindtypeREAL1)
4383 /* We used to call FFECOM_gfrtAMOD here. */
4384 gfrt = FFECOM_gfrtL_FMOD;
4385 else if (kt == FFEINFO_kindtypeREAL2)
4386 /* We used to call FFECOM_gfrtDMOD here. */
4387 gfrt = FFECOM_gfrtL_FMOD;
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 DECL_EXTERNAL (cbt) = 0;
6083 /* Give the array a size now. */
6085 size = build_int_2 ((ffeglobal_common_size (global)
6086 + ffeglobal_common_pad (global)) - 1,
6089 cbtype = TREE_TYPE (cbt);
6090 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6093 if (!TREE_TYPE (size))
6094 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6095 layout_type (cbtype);
6097 cbt = start_decl (cbt, FALSE);
6098 assert (cbt == ffeglobal_hook (global));
6100 finish_decl (cbt, NULL_TREE, FALSE);
6106 /* Finish up any untransformed symbols. */
6108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6110 ffecom_finish_symbol_transform_ (ffesymbol s)
6112 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6115 /* It's easy to know to transform an untransformed symbol, to make sure
6116 we put out debugging info for it. But COMMON variables, unlike
6117 EQUIVALENCE ones, aren't given declarations in addition to the
6118 tree expressions that specify offsets, because COMMON variables
6119 can be referenced in the outer scope where only dummy arguments
6120 (PARM_DECLs) should really be seen. To be safe, just don't do any
6121 VAR_DECLs for COMMON variables when we transform them for real
6122 use, and therefore we do all the VAR_DECL creating here. */
6124 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6126 if (ffesymbol_kind (s) != FFEINFO_kindNONE
6127 || (ffesymbol_where (s) != FFEINFO_whereNONE
6128 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6129 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6130 /* Not transformed, and not CHARACTER*(*), and not a dummy
6131 argument, which can happen only if the entry point names
6132 it "rides in on" are all invalidated for other reasons. */
6133 s = ffecom_sym_transform_ (s);
6136 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6137 && (ffesymbol_hook (s).decl_tree != error_mark_node))
6139 /* This isn't working, at least for dbxout. The .s file looks
6140 okay to me (burley), but in gdb 4.9 at least, the variables
6141 appear to reside somewhere outside of the common area, so
6142 it doesn't make sense to mislead anyone by generating the info
6143 on those variables until this is fixed. NOTE: Same problem
6144 with EQUIVALENCE, sadly...see similar #if later. */
6145 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6146 ffesymbol_storage (s));
6153 /* Append underscore(s) to name before calling get_identifier. "us"
6154 is nonzero if the name already contains an underscore and thus
6155 needs two underscores appended. */
6157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6159 ffecom_get_appended_identifier_ (char us, const char *name)
6165 newname = xmalloc ((i = strlen (name)) + 1
6166 + ffe_is_underscoring ()
6168 memcpy (newname, name, i);
6170 newname[i + us] = '_';
6171 newname[i + 1 + us] = '\0';
6172 id = get_identifier (newname);
6180 /* Decide whether to append underscore to name before calling
6183 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6185 ffecom_get_external_identifier_ (ffesymbol s)
6188 const char *name = ffesymbol_text (s);
6190 /* If name is a built-in name, just return it as is. */
6192 if (!ffe_is_underscoring ()
6193 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6194 #if FFETARGET_isENFORCED_MAIN_NAME
6195 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6197 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6199 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6200 return get_identifier (name);
6202 us = ffe_is_second_underscore ()
6203 ? (strchr (name, '_') != NULL)
6206 return ffecom_get_appended_identifier_ (us, name);
6210 /* Decide whether to append underscore to internal name before calling
6213 This is for non-external, top-function-context names only. Transform
6214 identifier so it doesn't conflict with the transformed result
6215 of using a _different_ external name. E.g. if "CALL FOO" is
6216 transformed into "FOO_();", then the variable in "FOO_ = 3"
6217 must be transformed into something that does not conflict, since
6218 these two things should be independent.
6220 The transformation is as follows. If the name does not contain
6221 an underscore, there is no possible conflict, so just return.
6222 If the name does contain an underscore, then transform it just
6223 like we transform an external identifier. */
6225 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6227 ffecom_get_identifier_ (const char *name)
6229 /* If name does not contain an underscore, just return it as is. */
6231 if (!ffe_is_underscoring ()
6232 || (strchr (name, '_') == NULL))
6233 return get_identifier (name);
6235 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6240 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6243 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6244 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6245 ffesymbol_kindtype(s));
6247 Call after setting up containing function and getting trees for all
6250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6252 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6254 ffebld expr = ffesymbol_sfexpr (s);
6258 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6259 static bool recurse = FALSE;
6260 int old_lineno = lineno;
6261 const char *old_input_filename = input_filename;
6263 ffecom_nested_entry_ = s;
6265 /* For now, we don't have a handy pointer to where the sfunc is actually
6266 defined, though that should be easy to add to an ffesymbol. (The
6267 token/where info available might well point to the place where the type
6268 of the sfunc is declared, especially if that precedes the place where
6269 the sfunc itself is defined, which is typically the case.) We should
6270 put out a null pointer rather than point somewhere wrong, but I want to
6271 see how it works at this point. */
6273 input_filename = ffesymbol_where_filename (s);
6274 lineno = ffesymbol_where_filelinenum (s);
6276 /* Pretransform the expression so any newly discovered things belong to the
6277 outer program unit, not to the statement function. */
6279 ffecom_expr_transform_ (expr);
6281 /* Make sure no recursive invocation of this fn (a specific case of failing
6282 to pretransform an sfunc's expression, i.e. where its expression
6283 references another untransformed sfunc) happens. */
6288 push_f_function_context ();
6291 type = void_type_node;
6294 type = ffecom_tree_type[bt][kt];
6295 if (type == NULL_TREE)
6296 type = integer_type_node; /* _sym_exec_transition reports
6300 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6301 build_function_type (type, NULL_TREE),
6302 1, /* nested/inline */
6303 0); /* TREE_PUBLIC */
6305 /* We don't worry about COMPLEX return values here, because this is
6306 entirely internal to our code, and gcc has the ability to return COMPLEX
6307 directly as a value. */
6310 { /* Prepend arg for where result goes. */
6313 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6315 result = ffecom_get_invented_identifier ("__g77_%s", "result");
6317 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6319 type = build_pointer_type (type);
6320 result = build_decl (PARM_DECL, result, type);
6322 push_parm_decl (result);
6325 result = NULL_TREE; /* Not ref'd if !charfunc. */
6327 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6329 store_parm_decls (0);
6331 ffecom_start_compstmt ();
6337 ffetargetCharacterSize sz = ffesymbol_size (s);
6340 result_length = build_int_2 (sz, 0);
6341 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6343 ffecom_prepare_let_char_ (sz, expr);
6345 ffecom_prepare_end ();
6347 ffecom_let_char_ (result, result_length, sz, expr);
6348 expand_null_return ();
6352 ffecom_prepare_expr (expr);
6354 ffecom_prepare_end ();
6356 expand_return (ffecom_modify (NULL_TREE,
6357 DECL_RESULT (current_function_decl),
6358 ffecom_expr (expr)));
6362 ffecom_end_compstmt ();
6364 func = current_function_decl;
6365 finish_function (1);
6367 pop_f_function_context ();
6371 lineno = old_lineno;
6372 input_filename = old_input_filename;
6374 ffecom_nested_entry_ = NULL;
6381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6383 ffecom_gfrt_args_ (ffecomGfrt ix)
6385 return ffecom_gfrt_argstring_[ix];
6389 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6391 ffecom_gfrt_tree_ (ffecomGfrt ix)
6393 if (ffecom_gfrt_[ix] == NULL_TREE)
6394 ffecom_make_gfrt_ (ix);
6396 return ffecom_1 (ADDR_EXPR,
6397 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6402 /* Return initialize-to-zero expression for this VAR_DECL. */
6404 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6405 /* A somewhat evil way to prevent the garbage collector
6406 from collecting 'tree' structures. */
6407 #define NUM_TRACKED_CHUNK 63
6408 static struct tree_ggc_tracker
6410 struct tree_ggc_tracker *next;
6411 tree trees[NUM_TRACKED_CHUNK];
6412 } *tracker_head = NULL;
6415 mark_tracker_head (void *arg)
6417 struct tree_ggc_tracker *head;
6420 for (head = * (struct tree_ggc_tracker **) arg;
6425 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6426 ggc_mark_tree (head->trees[i]);
6431 ffecom_save_tree_forever (tree t)
6434 if (tracker_head != NULL)
6435 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6436 if (tracker_head->trees[i] == NULL)
6438 tracker_head->trees[i] = t;
6443 /* Need to allocate a new block. */
6444 struct tree_ggc_tracker *old_head = tracker_head;
6446 tracker_head = ggc_alloc (sizeof (*tracker_head));
6447 tracker_head->next = old_head;
6448 tracker_head->trees[0] = t;
6449 for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6450 tracker_head->trees[i] = NULL;
6455 ffecom_init_zero_ (tree decl)
6458 int incremental = TREE_STATIC (decl);
6459 tree type = TREE_TYPE (decl);
6463 make_decl_rtl (decl, NULL);
6464 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6467 if ((TREE_CODE (type) != ARRAY_TYPE)
6468 && (TREE_CODE (type) != RECORD_TYPE)
6469 && (TREE_CODE (type) != UNION_TYPE)
6471 init = convert (type, integer_zero_node);
6472 else if (!incremental)
6474 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6475 TREE_CONSTANT (init) = 1;
6476 TREE_STATIC (init) = 1;
6480 assemble_zeros (int_size_in_bytes (type));
6481 init = error_mark_node;
6488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6490 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6496 switch (ffebld_op (arg))
6498 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6499 if (ffetarget_length_character1
6500 (ffebld_constant_character1
6501 (ffebld_conter (arg))) == 0)
6503 *maybe_tree = integer_zero_node;
6504 return convert (tree_type, integer_zero_node);
6507 *maybe_tree = integer_one_node;
6508 expr_tree = build_int_2 (*ffetarget_text_character1
6509 (ffebld_constant_character1
6510 (ffebld_conter (arg))),
6512 TREE_TYPE (expr_tree) = tree_type;
6515 case FFEBLD_opSYMTER:
6516 case FFEBLD_opARRAYREF:
6517 case FFEBLD_opFUNCREF:
6518 case FFEBLD_opSUBSTR:
6519 ffecom_char_args_ (&expr_tree, &length_tree, arg);
6521 if ((expr_tree == error_mark_node)
6522 || (length_tree == error_mark_node))
6524 *maybe_tree = error_mark_node;
6525 return error_mark_node;
6528 if (integer_zerop (length_tree))
6530 *maybe_tree = integer_zero_node;
6531 return convert (tree_type, integer_zero_node);
6535 = ffecom_1 (INDIRECT_REF,
6536 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6539 = ffecom_2 (ARRAY_REF,
6540 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6543 expr_tree = convert (tree_type, expr_tree);
6545 if (TREE_CODE (length_tree) == INTEGER_CST)
6546 *maybe_tree = integer_one_node;
6547 else /* Must check length at run time. */
6549 = ffecom_truth_value
6550 (ffecom_2 (GT_EXPR, integer_type_node,
6552 ffecom_f2c_ftnlen_zero_node));
6555 case FFEBLD_opPAREN:
6556 case FFEBLD_opCONVERT:
6557 if (ffeinfo_size (ffebld_info (arg)) == 0)
6559 *maybe_tree = integer_zero_node;
6560 return convert (tree_type, integer_zero_node);
6562 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6565 case FFEBLD_opCONCATENATE:
6572 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6574 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6576 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6579 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6587 assert ("bad op in ICHAR" == NULL);
6588 return error_mark_node;
6593 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6597 length_arg = ffecom_intrinsic_len_ (expr);
6599 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6600 subexpressions by constructing the appropriate tree for the
6601 length-of-character-text argument in a calling sequence. */
6603 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6605 ffecom_intrinsic_len_ (ffebld expr)
6607 ffetargetCharacter1 val;
6610 switch (ffebld_op (expr))
6612 case FFEBLD_opCONTER:
6613 val = ffebld_constant_character1 (ffebld_conter (expr));
6614 length = build_int_2 (ffetarget_length_character1 (val), 0);
6615 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6618 case FFEBLD_opSYMTER:
6620 ffesymbol s = ffebld_symter (expr);
6623 item = ffesymbol_hook (s).decl_tree;
6624 if (item == NULL_TREE)
6626 s = ffecom_sym_transform_ (s);
6627 item = ffesymbol_hook (s).decl_tree;
6629 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6631 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6632 length = ffesymbol_hook (s).length_tree;
6635 length = build_int_2 (ffesymbol_size (s), 0);
6636 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6639 else if (item == error_mark_node)
6640 length = error_mark_node;
6641 else /* FFEINFO_kindFUNCTION: */
6646 case FFEBLD_opARRAYREF:
6647 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6650 case FFEBLD_opSUBSTR:
6654 ffebld thing = ffebld_right (expr);
6658 assert (ffebld_op (thing) == FFEBLD_opITEM);
6659 start = ffebld_head (thing);
6660 thing = ffebld_trail (thing);
6661 assert (ffebld_trail (thing) == NULL);
6662 end = ffebld_head (thing);
6664 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6666 if (length == error_mark_node)
6675 length = convert (ffecom_f2c_ftnlen_type_node,
6681 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6682 ffecom_expr (start));
6684 if (start_tree == error_mark_node)
6686 length = error_mark_node;
6692 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6693 ffecom_f2c_ftnlen_one_node,
6694 ffecom_2 (MINUS_EXPR,
6695 ffecom_f2c_ftnlen_type_node,
6701 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6704 if (end_tree == error_mark_node)
6706 length = error_mark_node;
6710 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6711 ffecom_f2c_ftnlen_one_node,
6712 ffecom_2 (MINUS_EXPR,
6713 ffecom_f2c_ftnlen_type_node,
6714 end_tree, start_tree));
6720 case FFEBLD_opCONCATENATE:
6722 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6723 ffecom_intrinsic_len_ (ffebld_left (expr)),
6724 ffecom_intrinsic_len_ (ffebld_right (expr)));
6727 case FFEBLD_opFUNCREF:
6728 case FFEBLD_opCONVERT:
6729 length = build_int_2 (ffebld_size (expr), 0);
6730 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6734 assert ("bad op for single char arg expr" == NULL);
6735 length = ffecom_f2c_ftnlen_zero_node;
6739 assert (length != NULL_TREE);
6745 /* Handle CHARACTER assignments.
6747 Generates code to do the assignment. Used by ordinary assignment
6748 statement handler ffecom_let_stmt and by statement-function
6749 handler to generate code for a statement function. */
6751 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6753 ffecom_let_char_ (tree dest_tree, tree dest_length,
6754 ffetargetCharacterSize dest_size, ffebld source)
6756 ffecomConcatList_ catlist;
6761 if ((dest_tree == error_mark_node)
6762 || (dest_length == error_mark_node))
6765 assert (dest_tree != NULL_TREE);
6766 assert (dest_length != NULL_TREE);
6768 /* Source might be an opCONVERT, which just means it is a different size
6769 than the destination. Since the underlying implementation here handles
6770 that (directly or via the s_copy or s_cat run-time-library functions),
6771 we don't need the "convenience" of an opCONVERT that tells us to
6772 truncate or blank-pad, particularly since the resulting implementation
6773 would probably be slower than otherwise. */
6775 while (ffebld_op (source) == FFEBLD_opCONVERT)
6776 source = ffebld_left (source);
6778 catlist = ffecom_concat_list_new_ (source, dest_size);
6779 switch (ffecom_concat_list_count_ (catlist))
6781 case 0: /* Shouldn't happen, but in case it does... */
6782 ffecom_concat_list_kill_ (catlist);
6783 source_tree = null_pointer_node;
6784 source_length = ffecom_f2c_ftnlen_zero_node;
6785 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6786 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6787 TREE_CHAIN (TREE_CHAIN (expr_tree))
6788 = build_tree_list (NULL_TREE, dest_length);
6789 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6790 = build_tree_list (NULL_TREE, source_length);
6792 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6793 TREE_SIDE_EFFECTS (expr_tree) = 1;
6795 expand_expr_stmt (expr_tree);
6799 case 1: /* The (fairly) easy case. */
6800 ffecom_char_args_ (&source_tree, &source_length,
6801 ffecom_concat_list_expr_ (catlist, 0));
6802 ffecom_concat_list_kill_ (catlist);
6803 assert (source_tree != NULL_TREE);
6804 assert (source_length != NULL_TREE);
6806 if ((source_tree == error_mark_node)
6807 || (source_length == error_mark_node))
6813 = ffecom_1 (INDIRECT_REF,
6814 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6818 = ffecom_2 (ARRAY_REF,
6819 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6824 = ffecom_1 (INDIRECT_REF,
6825 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6829 = ffecom_2 (ARRAY_REF,
6830 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6835 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6837 expand_expr_stmt (expr_tree);
6842 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6843 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6844 TREE_CHAIN (TREE_CHAIN (expr_tree))
6845 = build_tree_list (NULL_TREE, dest_length);
6846 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6847 = build_tree_list (NULL_TREE, source_length);
6849 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6850 TREE_SIDE_EFFECTS (expr_tree) = 1;
6852 expand_expr_stmt (expr_tree);
6856 default: /* Must actually concatenate things. */
6860 /* Heavy-duty concatenation. */
6863 int count = ffecom_concat_list_count_ (catlist);
6875 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6876 FFETARGET_charactersizeNONE, count, TRUE);
6877 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6878 FFETARGET_charactersizeNONE,
6884 hook = ffebld_nonter_hook (source);
6886 assert (TREE_CODE (hook) == TREE_VEC);
6887 assert (TREE_VEC_LENGTH (hook) == 2);
6888 length_array = lengths = TREE_VEC_ELT (hook, 0);
6889 item_array = items = TREE_VEC_ELT (hook, 1);
6893 for (i = 0; i < count; ++i)
6895 ffecom_char_args_ (&citem, &clength,
6896 ffecom_concat_list_expr_ (catlist, i));
6897 if ((citem == error_mark_node)
6898 || (clength == error_mark_node))
6900 ffecom_concat_list_kill_ (catlist);
6905 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6906 ffecom_modify (void_type_node,
6907 ffecom_2 (ARRAY_REF,
6908 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6910 build_int_2 (i, 0)),
6914 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6915 ffecom_modify (void_type_node,
6916 ffecom_2 (ARRAY_REF,
6917 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6919 build_int_2 (i, 0)),
6924 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6925 TREE_CHAIN (expr_tree)
6926 = build_tree_list (NULL_TREE,
6927 ffecom_1 (ADDR_EXPR,
6928 build_pointer_type (TREE_TYPE (items)),
6930 TREE_CHAIN (TREE_CHAIN (expr_tree))
6931 = build_tree_list (NULL_TREE,
6932 ffecom_1 (ADDR_EXPR,
6933 build_pointer_type (TREE_TYPE (lengths)),
6935 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6938 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6939 convert (ffecom_f2c_ftnlen_type_node,
6940 build_int_2 (count, 0))));
6941 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6942 = build_tree_list (NULL_TREE, dest_length);
6944 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6945 TREE_SIDE_EFFECTS (expr_tree) = 1;
6947 expand_expr_stmt (expr_tree);
6950 ffecom_concat_list_kill_ (catlist);
6954 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6957 ffecom_make_gfrt_(ix);
6959 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6960 for the indicated run-time routine (ix). */
6962 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6964 ffecom_make_gfrt_ (ffecomGfrt ix)
6969 switch (ffecom_gfrt_type_[ix])
6971 case FFECOM_rttypeVOID_:
6972 ttype = void_type_node;
6975 case FFECOM_rttypeVOIDSTAR_:
6976 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
6979 case FFECOM_rttypeFTNINT_:
6980 ttype = ffecom_f2c_ftnint_type_node;
6983 case FFECOM_rttypeINTEGER_:
6984 ttype = ffecom_f2c_integer_type_node;
6987 case FFECOM_rttypeLONGINT_:
6988 ttype = ffecom_f2c_longint_type_node;
6991 case FFECOM_rttypeLOGICAL_:
6992 ttype = ffecom_f2c_logical_type_node;
6995 case FFECOM_rttypeREAL_F2C_:
6996 ttype = double_type_node;
6999 case FFECOM_rttypeREAL_GNU_:
7000 ttype = float_type_node;
7003 case FFECOM_rttypeCOMPLEX_F2C_:
7004 ttype = void_type_node;
7007 case FFECOM_rttypeCOMPLEX_GNU_:
7008 ttype = ffecom_f2c_complex_type_node;
7011 case FFECOM_rttypeDOUBLE_:
7012 ttype = double_type_node;
7015 case FFECOM_rttypeDOUBLEREAL_:
7016 ttype = ffecom_f2c_doublereal_type_node;
7019 case FFECOM_rttypeDBLCMPLX_F2C_:
7020 ttype = void_type_node;
7023 case FFECOM_rttypeDBLCMPLX_GNU_:
7024 ttype = ffecom_f2c_doublecomplex_type_node;
7027 case FFECOM_rttypeCHARACTER_:
7028 ttype = void_type_node;
7033 assert ("bad rttype" == NULL);
7037 ttype = build_function_type (ttype, NULL_TREE);
7038 t = build_decl (FUNCTION_DECL,
7039 get_identifier (ffecom_gfrt_name_[ix]),
7041 DECL_EXTERNAL (t) = 1;
7042 TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7043 TREE_PUBLIC (t) = 1;
7044 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7046 /* Sanity check: A function that's const cannot be volatile. */
7048 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7050 /* Sanity check: A function that's const cannot return complex. */
7052 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7054 t = start_decl (t, TRUE);
7056 finish_decl (t, NULL_TREE, TRUE);
7058 ffecom_gfrt_[ix] = t;
7062 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7064 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7066 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7068 ffesymbol s = ffestorag_symbol (st);
7070 if (ffesymbol_namelisted (s))
7071 ffecom_member_namelisted_ = TRUE;
7075 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7076 the member so debugger will see it. Otherwise nobody should be
7077 referencing the member. */
7079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7081 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7089 || ((mt = ffestorag_hook (mst)) == NULL)
7090 || (mt == error_mark_node))
7094 || ((s = ffestorag_symbol (st)) == NULL))
7097 type = ffecom_type_localvar_ (s,
7098 ffesymbol_basictype (s),
7099 ffesymbol_kindtype (s));
7100 if (type == error_mark_node)
7103 t = build_decl (VAR_DECL,
7104 ffecom_get_identifier_ (ffesymbol_text (s)),
7107 TREE_STATIC (t) = TREE_STATIC (mt);
7108 DECL_INITIAL (t) = NULL_TREE;
7109 TREE_ASM_WRITTEN (t) = 1;
7113 = gen_rtx (MEM, TYPE_MODE (type),
7114 plus_constant (XEXP (DECL_RTL (mt), 0),
7115 ffestorag_modulo (mst)
7116 + ffestorag_offset (st)
7117 - ffestorag_offset (mst)));
7119 t = start_decl (t, FALSE);
7121 finish_decl (t, NULL_TREE, FALSE);
7125 /* Prepare source expression for assignment into a destination perhaps known
7126 to be of a specific size. */
7129 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7131 ffecomConcatList_ catlist;
7136 tree tempvar = NULL_TREE;
7138 while (ffebld_op (source) == FFEBLD_opCONVERT)
7139 source = ffebld_left (source);
7141 catlist = ffecom_concat_list_new_ (source, dest_size);
7142 count = ffecom_concat_list_count_ (catlist);
7147 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7148 FFETARGET_charactersizeNONE, count);
7150 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7151 FFETARGET_charactersizeNONE, count);
7153 tempvar = make_tree_vec (2);
7154 TREE_VEC_ELT (tempvar, 0) = ltmp;
7155 TREE_VEC_ELT (tempvar, 1) = itmp;
7158 for (i = 0; i < count; ++i)
7159 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7161 ffecom_concat_list_kill_ (catlist);
7165 ffebld_nonter_set_hook (source, tempvar);
7166 current_binding_level->prep_state = 1;
7170 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7172 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7173 (which generates their trees) and then their trees get push_parm_decl'd.
7175 The second arg is TRUE if the dummies are for a statement function, in
7176 which case lengths are not pushed for character arguments (since they are
7177 always known by both the caller and the callee, though the code allows
7178 for someday permitting CHAR*(*) stmtfunc dummies). */
7180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7182 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7189 ffecom_transform_only_dummies_ = TRUE;
7191 /* First push the parms corresponding to actual dummy "contents". */
7193 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7195 dummy = ffebld_head (dumlist);
7196 switch (ffebld_op (dummy))
7200 continue; /* Forget alternate returns. */
7205 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7206 s = ffebld_symter (dummy);
7207 parm = ffesymbol_hook (s).decl_tree;
7208 if (parm == NULL_TREE)
7210 s = ffecom_sym_transform_ (s);
7211 parm = ffesymbol_hook (s).decl_tree;
7212 assert (parm != NULL_TREE);
7214 if (parm != error_mark_node)
7215 push_parm_decl (parm);
7218 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7220 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7222 dummy = ffebld_head (dumlist);
7223 switch (ffebld_op (dummy))
7227 continue; /* Forget alternate returns, they mean
7233 s = ffebld_symter (dummy);
7234 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7235 continue; /* Only looking for CHARACTER arguments. */
7236 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7237 continue; /* Stmtfunc arg with known size needs no
7239 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7240 continue; /* Only looking for variables and arrays. */
7241 parm = ffesymbol_hook (s).length_tree;
7242 assert (parm != NULL_TREE);
7243 if (parm != error_mark_node)
7244 push_parm_decl (parm);
7247 ffecom_transform_only_dummies_ = FALSE;
7251 /* ffecom_start_progunit_ -- Beginning of program unit
7253 Does GNU back end stuff necessary to teach it about the start of its
7254 equivalent of a Fortran program unit. */
7256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7258 ffecom_start_progunit_ ()
7260 ffesymbol fn = ffecom_primary_entry_;
7262 tree id; /* Identifier (name) of function. */
7263 tree type; /* Type of function. */
7264 tree result; /* Result of function. */
7265 ffeinfoBasictype bt;
7269 ffeglobalType egt = FFEGLOBAL_type;
7272 bool altentries = (ffecom_num_entrypoints_ != 0);
7275 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7276 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7277 bool main_program = FALSE;
7278 int old_lineno = lineno;
7279 const char *old_input_filename = input_filename;
7281 assert (fn != NULL);
7282 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7284 input_filename = ffesymbol_where_filename (fn);
7285 lineno = ffesymbol_where_filelinenum (fn);
7287 switch (ffecom_primary_entry_kind_)
7289 case FFEINFO_kindPROGRAM:
7290 main_program = TRUE;
7291 gt = FFEGLOBAL_typeMAIN;
7292 bt = FFEINFO_basictypeNONE;
7293 kt = FFEINFO_kindtypeNONE;
7294 type = ffecom_tree_fun_type_void;
7299 case FFEINFO_kindBLOCKDATA:
7300 gt = FFEGLOBAL_typeBDATA;
7301 bt = FFEINFO_basictypeNONE;
7302 kt = FFEINFO_kindtypeNONE;
7303 type = ffecom_tree_fun_type_void;
7308 case FFEINFO_kindFUNCTION:
7309 gt = FFEGLOBAL_typeFUNC;
7310 egt = FFEGLOBAL_typeEXT;
7311 bt = ffesymbol_basictype (fn);
7312 kt = ffesymbol_kindtype (fn);
7313 if (bt == FFEINFO_basictypeNONE)
7315 ffeimplic_establish_symbol (fn);
7316 if (ffesymbol_funcresult (fn) != NULL)
7317 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7318 bt = ffesymbol_basictype (fn);
7319 kt = ffesymbol_kindtype (fn);
7323 charfunc = cmplxfunc = FALSE;
7324 else if (bt == FFEINFO_basictypeCHARACTER)
7325 charfunc = TRUE, cmplxfunc = FALSE;
7326 else if ((bt == FFEINFO_basictypeCOMPLEX)
7327 && ffesymbol_is_f2c (fn)
7329 charfunc = FALSE, cmplxfunc = TRUE;
7331 charfunc = cmplxfunc = FALSE;
7333 if (multi || charfunc)
7334 type = ffecom_tree_fun_type_void;
7335 else if (ffesymbol_is_f2c (fn) && !altentries)
7336 type = ffecom_tree_fun_type[bt][kt];
7338 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7340 if ((type == NULL_TREE)
7341 || (TREE_TYPE (type) == NULL_TREE))
7342 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7345 case FFEINFO_kindSUBROUTINE:
7346 gt = FFEGLOBAL_typeSUBR;
7347 egt = FFEGLOBAL_typeEXT;
7348 bt = FFEINFO_basictypeNONE;
7349 kt = FFEINFO_kindtypeNONE;
7350 if (ffecom_is_altreturning_)
7351 type = ffecom_tree_subr_type;
7353 type = ffecom_tree_fun_type_void;
7359 assert ("say what??" == NULL);
7361 case FFEINFO_kindANY:
7362 gt = FFEGLOBAL_typeANY;
7363 bt = FFEINFO_basictypeNONE;
7364 kt = FFEINFO_kindtypeNONE;
7365 type = error_mark_node;
7373 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7374 ffesymbol_text (fn));
7376 #if FFETARGET_isENFORCED_MAIN
7377 else if (main_program)
7378 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7381 id = ffecom_get_external_identifier_ (fn);
7385 0, /* nested/inline */
7386 !altentries); /* TREE_PUBLIC */
7388 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
7391 && ((g = ffesymbol_global (fn)) != NULL)
7392 && ((ffeglobal_type (g) == gt)
7393 || (ffeglobal_type (g) == egt)))
7395 ffeglobal_set_hook (g, current_function_decl);
7398 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7399 exec-transitioning needs current_function_decl to be filled in. So we
7400 do these things in two phases. */
7403 { /* 1st arg identifies which entrypoint. */
7404 ffecom_which_entrypoint_decl_
7405 = build_decl (PARM_DECL,
7406 ffecom_get_invented_identifier ("__g77_%s",
7407 "which_entrypoint"),
7409 push_parm_decl (ffecom_which_entrypoint_decl_);
7415 { /* Arg for result (return value). */
7420 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7422 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7424 type = ffecom_multi_type_node_;
7426 result = ffecom_get_invented_identifier ("__g77_%s", "result");
7428 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7431 length = ffecom_char_enhance_arg_ (&type, fn);
7433 length = NULL_TREE; /* Not ref'd if !charfunc. */
7435 type = build_pointer_type (type);
7436 result = build_decl (PARM_DECL, result, type);
7438 push_parm_decl (result);
7440 ffecom_multi_retval_ = result;
7442 ffecom_func_result_ = result;
7446 push_parm_decl (length);
7447 ffecom_func_length_ = length;
7451 if (ffecom_primary_entry_is_proc_)
7454 arglist = ffecom_master_arglist_;
7456 arglist = ffesymbol_dummyargs (fn);
7457 ffecom_push_dummy_decls_ (arglist, FALSE);
7460 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7461 store_parm_decls (main_program ? 1 : 0);
7463 ffecom_start_compstmt ();
7464 /* Disallow temp vars at this level. */
7465 current_binding_level->prep_state = 2;
7467 lineno = old_lineno;
7468 input_filename = old_input_filename;
7470 /* This handles any symbols still untransformed, in case -g specified.
7471 This used to be done in ffecom_finish_progunit, but it turns out to
7472 be necessary to do it here so that statement functions are
7473 expanded before code. But don't bother for BLOCK DATA. */
7475 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7476 ffesymbol_drive (ffecom_finish_symbol_transform_);
7480 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7483 ffecom_sym_transform_(s);
7485 The ffesymbol_hook info for s is updated with appropriate backend info
7488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7490 ffecom_sym_transform_ (ffesymbol s)
7492 tree t; /* Transformed thingy. */
7493 tree tlen; /* Length if CHAR*(*). */
7494 bool addr; /* Is t the address of the thingy? */
7495 ffeinfoBasictype bt;
7498 int old_lineno = lineno;
7499 const char *old_input_filename = input_filename;
7501 /* Must ensure special ASSIGN variables are declared at top of outermost
7502 block, else they'll end up in the innermost block when their first
7503 ASSIGN is seen, which leaves them out of scope when they're the
7504 subject of a GOTO or I/O statement.
7506 We make this variable even if -fugly-assign. Just let it go unused,
7507 in case it turns out there are cases where we really want to use this
7508 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7510 if (! ffecom_transform_only_dummies_
7511 && ffesymbol_assigned (s)
7512 && ! ffesymbol_hook (s).assign_tree)
7513 s = ffecom_sym_transform_assign_ (s);
7515 if (ffesymbol_sfdummyparent (s) == NULL)
7517 input_filename = ffesymbol_where_filename (s);
7518 lineno = ffesymbol_where_filelinenum (s);
7522 ffesymbol sf = ffesymbol_sfdummyparent (s);
7524 input_filename = ffesymbol_where_filename (sf);
7525 lineno = ffesymbol_where_filelinenum (sf);
7528 bt = ffeinfo_basictype (ffebld_info (s));
7529 kt = ffeinfo_kindtype (ffebld_info (s));
7535 switch (ffesymbol_kind (s))
7537 case FFEINFO_kindNONE:
7538 switch (ffesymbol_where (s))
7540 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7541 assert (ffecom_transform_only_dummies_);
7543 /* Before 0.4, this could be ENTITY/DUMMY, but see
7544 ffestu_sym_end_transition -- no longer true (in particular, if
7545 it could be an ENTITY, it _will_ be made one, so that
7546 possibility won't come through here). So we never make length
7547 arg for CHARACTER type. */
7549 t = build_decl (PARM_DECL,
7550 ffecom_get_identifier_ (ffesymbol_text (s)),
7551 ffecom_tree_ptr_to_subr_type);
7553 DECL_ARTIFICIAL (t) = 1;
7558 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7559 assert (!ffecom_transform_only_dummies_);
7561 if (((g = ffesymbol_global (s)) != NULL)
7562 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7563 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7564 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7565 && (ffeglobal_hook (g) != NULL_TREE)
7566 && ffe_is_globals ())
7568 t = ffeglobal_hook (g);
7572 t = build_decl (FUNCTION_DECL,
7573 ffecom_get_external_identifier_ (s),
7574 ffecom_tree_subr_type); /* Assume subr. */
7575 DECL_EXTERNAL (t) = 1;
7576 TREE_PUBLIC (t) = 1;
7578 t = start_decl (t, FALSE);
7579 finish_decl (t, NULL_TREE, FALSE);
7582 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7583 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7584 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7585 ffeglobal_set_hook (g, t);
7587 ffecom_save_tree_forever (t);
7592 assert ("NONE where unexpected" == NULL);
7594 case FFEINFO_whereANY:
7599 case FFEINFO_kindENTITY:
7600 switch (ffeinfo_where (ffesymbol_info (s)))
7603 case FFEINFO_whereCONSTANT:
7604 /* ~~Debugging info needed? */
7605 assert (!ffecom_transform_only_dummies_);
7606 t = error_mark_node; /* Shouldn't ever see this in expr. */
7609 case FFEINFO_whereLOCAL:
7610 assert (!ffecom_transform_only_dummies_);
7613 ffestorag st = ffesymbol_storage (s);
7617 && (ffestorag_size (st) == 0))
7619 t = error_mark_node;
7623 type = ffecom_type_localvar_ (s, bt, kt);
7625 if (type == error_mark_node)
7627 t = error_mark_node;
7632 && (ffestorag_parent (st) != NULL))
7633 { /* Child of EQUIVALENCE parent. */
7636 ffetargetOffset offset;
7638 est = ffestorag_parent (st);
7639 ffecom_transform_equiv_ (est);
7641 et = ffestorag_hook (est);
7642 assert (et != NULL_TREE);
7644 if (! TREE_STATIC (et))
7645 put_var_into_stack (et);
7647 offset = ffestorag_modulo (est)
7648 + ffestorag_offset (ffesymbol_storage (s))
7649 - ffestorag_offset (est);
7651 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7653 /* (t_type *) (((char *) &et) + offset) */
7655 t = convert (string_type_node, /* (char *) */
7656 ffecom_1 (ADDR_EXPR,
7657 build_pointer_type (TREE_TYPE (et)),
7659 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7661 build_int_2 (offset, 0));
7662 t = convert (build_pointer_type (type),
7664 TREE_CONSTANT (t) = staticp (et);
7671 bool init = ffesymbol_is_init (s);
7673 t = build_decl (VAR_DECL,
7674 ffecom_get_identifier_ (ffesymbol_text (s)),
7678 || ffesymbol_namelisted (s)
7679 #ifdef FFECOM_sizeMAXSTACKITEM
7681 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7683 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7684 && (ffecom_primary_entry_kind_
7685 != FFEINFO_kindBLOCKDATA)
7686 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7687 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7689 TREE_STATIC (t) = 0; /* No need to make static. */
7691 if (init || ffe_is_init_local_zero ())
7692 DECL_INITIAL (t) = error_mark_node;
7694 /* Keep -Wunused from complaining about var if it
7695 is used as sfunc arg or DATA implied-DO. */
7696 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7697 DECL_IN_SYSTEM_HEADER (t) = 1;
7699 t = start_decl (t, FALSE);
7703 if (ffesymbol_init (s) != NULL)
7704 initexpr = ffecom_expr (ffesymbol_init (s));
7706 initexpr = ffecom_init_zero_ (t);
7708 else if (ffe_is_init_local_zero ())
7709 initexpr = ffecom_init_zero_ (t);
7711 initexpr = NULL_TREE; /* Not ref'd if !init. */
7713 finish_decl (t, initexpr, FALSE);
7715 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7717 assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7718 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7719 ffestorag_size (st)));
7725 case FFEINFO_whereRESULT:
7726 assert (!ffecom_transform_only_dummies_);
7728 if (bt == FFEINFO_basictypeCHARACTER)
7729 { /* Result is already in list of dummies, use
7731 t = ffecom_func_result_;
7732 tlen = ffecom_func_length_;
7736 if ((ffecom_num_entrypoints_ == 0)
7737 && (bt == FFEINFO_basictypeCOMPLEX)
7738 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7739 { /* Result is already in list of dummies, use
7741 t = ffecom_func_result_;
7745 if (ffecom_func_result_ != NULL_TREE)
7747 t = ffecom_func_result_;
7750 if ((ffecom_num_entrypoints_ != 0)
7751 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7753 assert (ffecom_multi_retval_ != NULL_TREE);
7754 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7755 ffecom_multi_retval_);
7756 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7757 t, ffecom_multi_fields_[bt][kt]);
7762 t = build_decl (VAR_DECL,
7763 ffecom_get_identifier_ (ffesymbol_text (s)),
7764 ffecom_tree_type[bt][kt]);
7765 TREE_STATIC (t) = 0; /* Put result on stack. */
7766 t = start_decl (t, FALSE);
7767 finish_decl (t, NULL_TREE, FALSE);
7769 ffecom_func_result_ = t;
7773 case FFEINFO_whereDUMMY:
7781 bool adjustable = FALSE; /* Conditionally adjustable? */
7783 type = ffecom_tree_type[bt][kt];
7784 if (ffesymbol_sfdummyparent (s) != NULL)
7786 if (current_function_decl == ffecom_outer_function_decl_)
7787 { /* Exec transition before sfunc
7788 context; get it later. */
7791 t = ffecom_get_identifier_ (ffesymbol_text
7792 (ffesymbol_sfdummyparent (s)));
7795 t = ffecom_get_identifier_ (ffesymbol_text (s));
7797 assert (ffecom_transform_only_dummies_);
7799 old_sizes = get_pending_sizes ();
7800 put_pending_sizes (old_sizes);
7802 if (bt == FFEINFO_basictypeCHARACTER)
7803 tlen = ffecom_char_enhance_arg_ (&type, s);
7804 type = ffecom_check_size_overflow_ (s, type, TRUE);
7806 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7808 if (type == error_mark_node)
7811 dim = ffebld_head (dl);
7812 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7813 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7814 low = ffecom_integer_one_node;
7816 low = ffecom_expr (ffebld_left (dim));
7817 assert (ffebld_right (dim) != NULL);
7818 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7819 || ffecom_doing_entry_)
7821 /* Used to just do high=low. But for ffecom_tree_
7822 canonize_ref_, it probably is important to correctly
7823 assess the size. E.g. given COMPLEX C(*),CFUNC and
7824 C(2)=CFUNC(C), overlap can happen, while it can't
7825 for, say, C(1)=CFUNC(C(2)). */
7826 /* Even more recently used to set to INT_MAX, but that
7827 broke when some overflow checking went into the back
7828 end. Now we just leave the upper bound unspecified. */
7832 high = ffecom_expr (ffebld_right (dim));
7834 /* Determine whether array is conditionally adjustable,
7835 to decide whether back-end magic is needed.
7837 Normally the front end uses the back-end function
7838 variable_size to wrap SAVE_EXPR's around expressions
7839 affecting the size/shape of an array so that the
7840 size/shape info doesn't change during execution
7841 of the compiled code even though variables and
7842 functions referenced in those expressions might.
7844 variable_size also makes sure those saved expressions
7845 get evaluated immediately upon entry to the
7846 compiled procedure -- the front end normally doesn't
7847 have to worry about that.
7849 However, there is a problem with this that affects
7850 g77's implementation of entry points, and that is
7851 that it is _not_ true that each invocation of the
7852 compiled procedure is permitted to evaluate
7853 array size/shape info -- because it is possible
7854 that, for some invocations, that info is invalid (in
7855 which case it is "promised" -- i.e. a violation of
7856 the Fortran standard -- that the compiled code
7857 won't reference the array or its size/shape
7858 during that particular invocation).
7860 To phrase this in C terms, consider this gcc function:
7862 void foo (int *n, float (*a)[*n])
7864 // a is "pointer to array ...", fyi.
7867 Suppose that, for some invocations, it is permitted
7868 for a caller of foo to do this:
7872 Now the _written_ code for foo can take such a call
7873 into account by either testing explicitly for whether
7874 (a == NULL) || (n == NULL) -- presumably it is
7875 not permitted to reference *a in various fashions
7876 if (n == NULL) I suppose -- or it can avoid it by
7877 looking at other info (other arguments, static/global
7880 However, this won't work in gcc 2.5.8 because it'll
7881 automatically emit the code to save the "*n"
7882 expression, which'll yield a NULL dereference for
7883 the "foo (NULL, NULL)" call, something the code
7884 for foo cannot prevent.
7886 g77 definitely needs to avoid executing such
7887 code anytime the pointer to the adjustable array
7888 is NULL, because even if its bounds expressions
7889 don't have any references to possible "absent"
7890 variables like "*n" -- say all variable references
7891 are to COMMON variables, i.e. global (though in C,
7892 local static could actually make sense) -- the
7893 expressions could yield other run-time problems
7894 for allowably "dead" values in those variables.
7896 For example, let's consider a more complicated
7902 void foo (float (*a)[i/j])
7907 The above is (essentially) quite valid for Fortran
7908 but, again, for a call like "foo (NULL);", it is
7909 permitted for i and j to be undefined when the
7910 call is made. If j happened to be zero, for
7911 example, emitting the code to evaluate "i/j"
7912 could result in a run-time error.
7914 Offhand, though I don't have my F77 or F90
7915 standards handy, it might even be valid for a
7916 bounds expression to contain a function reference,
7917 in which case I doubt it is permitted for an
7918 implementation to invoke that function in the
7919 Fortran case involved here (invocation of an
7920 alternate ENTRY point that doesn't have the adjustable
7921 array as one of its arguments).
7923 So, the code that the compiler would normally emit
7924 to preevaluate the size/shape info for an
7925 adjustable array _must not_ be executed at run time
7926 in certain cases. Specifically, for Fortran,
7927 the case is when the pointer to the adjustable
7928 array == NULL. (For gnu-ish C, it might be nice
7929 for the source code itself to specify an expression
7930 that, if TRUE, inhibits execution of the code. Or
7931 reverse the sense for elegance.)
7933 (Note that g77 could use a different test than NULL,
7934 actually, since it happens to always pass an
7935 integer to the called function that specifies which
7936 entry point is being invoked. Hmm, this might
7937 solve the next problem.)
7939 One way a user could, I suppose, write "foo" so
7940 it works is to insert COND_EXPR's for the
7941 size/shape info so the dangerous stuff isn't
7942 actually done, as in:
7944 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7949 The next problem is that the front end needs to
7950 be able to tell the back end about the array's
7951 decl _before_ it tells it about the conditional
7952 expression to inhibit evaluation of size/shape info,
7955 To solve this, the front end needs to be able
7956 to give the back end the expression to inhibit
7957 generation of the preevaluation code _after_
7958 it makes the decl for the adjustable array.
7960 Until then, the above example using the COND_EXPR
7961 doesn't pass muster with gcc because the "(a == NULL)"
7962 part has a reference to "a", which is still
7963 undefined at that point.
7965 g77 will therefore use a different mechanism in the
7969 && ((TREE_CODE (low) != INTEGER_CST)
7970 || (high && TREE_CODE (high) != INTEGER_CST)))
7973 #if 0 /* Old approach -- see below. */
7974 if (TREE_CODE (low) != INTEGER_CST)
7975 low = ffecom_3 (COND_EXPR, integer_type_node,
7976 ffecom_adjarray_passed_ (s),
7978 ffecom_integer_zero_node);
7980 if (high && TREE_CODE (high) != INTEGER_CST)
7981 high = ffecom_3 (COND_EXPR, integer_type_node,
7982 ffecom_adjarray_passed_ (s),
7984 ffecom_integer_zero_node);
7987 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7988 probably. Fixes 950302-1.f. */
7990 if (TREE_CODE (low) != INTEGER_CST)
7991 low = variable_size (low);
7993 /* ~~~Similarly, this fixes dumb0.f. The C front end
7994 does this, which is why dumb0.c would work. */
7996 if (high && TREE_CODE (high) != INTEGER_CST)
7997 high = variable_size (high);
8002 build_range_type (ffecom_integer_type_node,
8004 type = ffecom_check_size_overflow_ (s, type, TRUE);
8007 if (type == error_mark_node)
8009 t = error_mark_node;
8013 if ((ffesymbol_sfdummyparent (s) == NULL)
8014 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8016 type = build_pointer_type (type);
8020 t = build_decl (PARM_DECL, t, type);
8022 DECL_ARTIFICIAL (t) = 1;
8025 /* If this arg is present in every entry point's list of
8026 dummy args, then we're done. */
8028 if (ffesymbol_numentries (s)
8029 == (ffecom_num_entrypoints_ + 1))
8034 /* If variable_size in stor-layout has been called during
8035 the above, then get_pending_sizes should have the
8036 yet-to-be-evaluated saved expressions pending.
8037 Make the whole lot of them get emitted, conditionally
8038 on whether the array decl ("t" above) is not NULL. */
8041 tree sizes = get_pending_sizes ();
8046 tem = TREE_CHAIN (tem))
8048 tree temv = TREE_VALUE (tem);
8054 = ffecom_2 (COMPOUND_EXPR,
8063 = ffecom_3 (COND_EXPR,
8070 convert (TREE_TYPE (sizes),
8071 integer_zero_node));
8072 sizes = ffecom_save_tree (sizes);
8075 = tree_cons (NULL_TREE, sizes, tem);
8079 put_pending_sizes (sizes);
8085 && (ffesymbol_numentries (s)
8086 != ffecom_num_entrypoints_ + 1))
8088 = ffecom_2 (NE_EXPR, integer_type_node,
8094 && (ffesymbol_numentries (s)
8095 != ffecom_num_entrypoints_ + 1))
8097 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8098 ffebad_here (0, ffesymbol_where_line (s),
8099 ffesymbol_where_column (s));
8100 ffebad_string (ffesymbol_text (s));
8109 case FFEINFO_whereCOMMON:
8114 ffestorag st = ffesymbol_storage (s);
8117 cs = ffesymbol_common (s); /* The COMMON area itself. */
8118 if (st != NULL) /* Else not laid out. */
8120 ffecom_transform_common_ (cs);
8121 st = ffesymbol_storage (s);
8124 type = ffecom_type_localvar_ (s, bt, kt);
8126 cg = ffesymbol_global (cs); /* The global COMMON info. */
8128 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8131 ct = ffeglobal_hook (cg); /* The common area's tree. */
8133 if ((ct == NULL_TREE)
8135 || (type == error_mark_node))
8136 t = error_mark_node;
8139 ffetargetOffset offset;
8142 cst = ffestorag_parent (st);
8143 assert (cst == ffesymbol_storage (cs));
8145 offset = ffestorag_modulo (cst)
8146 + ffestorag_offset (st)
8147 - ffestorag_offset (cst);
8149 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8151 /* (t_type *) (((char *) &ct) + offset) */
8153 t = convert (string_type_node, /* (char *) */
8154 ffecom_1 (ADDR_EXPR,
8155 build_pointer_type (TREE_TYPE (ct)),
8157 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8159 build_int_2 (offset, 0));
8160 t = convert (build_pointer_type (type),
8162 TREE_CONSTANT (t) = 1;
8169 case FFEINFO_whereIMMEDIATE:
8170 case FFEINFO_whereGLOBAL:
8171 case FFEINFO_whereFLEETING:
8172 case FFEINFO_whereFLEETING_CADDR:
8173 case FFEINFO_whereFLEETING_IADDR:
8174 case FFEINFO_whereINTRINSIC:
8175 case FFEINFO_whereCONSTANT_SUBOBJECT:
8177 assert ("ENTITY where unheard of" == NULL);
8179 case FFEINFO_whereANY:
8180 t = error_mark_node;
8185 case FFEINFO_kindFUNCTION:
8186 switch (ffeinfo_where (ffesymbol_info (s)))
8188 case FFEINFO_whereLOCAL: /* Me. */
8189 assert (!ffecom_transform_only_dummies_);
8190 t = current_function_decl;
8193 case FFEINFO_whereGLOBAL:
8194 assert (!ffecom_transform_only_dummies_);
8196 if (((g = ffesymbol_global (s)) != NULL)
8197 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8198 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8199 && (ffeglobal_hook (g) != NULL_TREE)
8200 && ffe_is_globals ())
8202 t = ffeglobal_hook (g);
8206 if (ffesymbol_is_f2c (s)
8207 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8208 t = ffecom_tree_fun_type[bt][kt];
8210 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8212 t = build_decl (FUNCTION_DECL,
8213 ffecom_get_external_identifier_ (s),
8215 DECL_EXTERNAL (t) = 1;
8216 TREE_PUBLIC (t) = 1;
8218 t = start_decl (t, FALSE);
8219 finish_decl (t, NULL_TREE, FALSE);
8222 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8223 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8224 ffeglobal_set_hook (g, t);
8226 ffecom_save_tree_forever (t);
8230 case FFEINFO_whereDUMMY:
8231 assert (ffecom_transform_only_dummies_);
8233 if (ffesymbol_is_f2c (s)
8234 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8235 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8237 t = build_pointer_type
8238 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8240 t = build_decl (PARM_DECL,
8241 ffecom_get_identifier_ (ffesymbol_text (s)),
8244 DECL_ARTIFICIAL (t) = 1;
8249 case FFEINFO_whereCONSTANT: /* Statement function. */
8250 assert (!ffecom_transform_only_dummies_);
8251 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8254 case FFEINFO_whereINTRINSIC:
8255 assert (!ffecom_transform_only_dummies_);
8256 break; /* Let actual references generate their
8260 assert ("FUNCTION where unheard of" == NULL);
8262 case FFEINFO_whereANY:
8263 t = error_mark_node;
8268 case FFEINFO_kindSUBROUTINE:
8269 switch (ffeinfo_where (ffesymbol_info (s)))
8271 case FFEINFO_whereLOCAL: /* Me. */
8272 assert (!ffecom_transform_only_dummies_);
8273 t = current_function_decl;
8276 case FFEINFO_whereGLOBAL:
8277 assert (!ffecom_transform_only_dummies_);
8279 if (((g = ffesymbol_global (s)) != NULL)
8280 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8281 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8282 && (ffeglobal_hook (g) != NULL_TREE)
8283 && ffe_is_globals ())
8285 t = ffeglobal_hook (g);
8289 t = build_decl (FUNCTION_DECL,
8290 ffecom_get_external_identifier_ (s),
8291 ffecom_tree_subr_type);
8292 DECL_EXTERNAL (t) = 1;
8293 TREE_PUBLIC (t) = 1;
8295 t = start_decl (t, FALSE);
8296 finish_decl (t, NULL_TREE, FALSE);
8299 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8300 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8301 ffeglobal_set_hook (g, t);
8303 ffecom_save_tree_forever (t);
8307 case FFEINFO_whereDUMMY:
8308 assert (ffecom_transform_only_dummies_);
8310 t = build_decl (PARM_DECL,
8311 ffecom_get_identifier_ (ffesymbol_text (s)),
8312 ffecom_tree_ptr_to_subr_type);
8314 DECL_ARTIFICIAL (t) = 1;
8319 case FFEINFO_whereINTRINSIC:
8320 assert (!ffecom_transform_only_dummies_);
8321 break; /* Let actual references generate their
8325 assert ("SUBROUTINE where unheard of" == NULL);
8327 case FFEINFO_whereANY:
8328 t = error_mark_node;
8333 case FFEINFO_kindPROGRAM:
8334 switch (ffeinfo_where (ffesymbol_info (s)))
8336 case FFEINFO_whereLOCAL: /* Me. */
8337 assert (!ffecom_transform_only_dummies_);
8338 t = current_function_decl;
8341 case FFEINFO_whereCOMMON:
8342 case FFEINFO_whereDUMMY:
8343 case FFEINFO_whereGLOBAL:
8344 case FFEINFO_whereRESULT:
8345 case FFEINFO_whereFLEETING:
8346 case FFEINFO_whereFLEETING_CADDR:
8347 case FFEINFO_whereFLEETING_IADDR:
8348 case FFEINFO_whereIMMEDIATE:
8349 case FFEINFO_whereINTRINSIC:
8350 case FFEINFO_whereCONSTANT:
8351 case FFEINFO_whereCONSTANT_SUBOBJECT:
8353 assert ("PROGRAM where unheard of" == NULL);
8355 case FFEINFO_whereANY:
8356 t = error_mark_node;
8361 case FFEINFO_kindBLOCKDATA:
8362 switch (ffeinfo_where (ffesymbol_info (s)))
8364 case FFEINFO_whereLOCAL: /* Me. */
8365 assert (!ffecom_transform_only_dummies_);
8366 t = current_function_decl;
8369 case FFEINFO_whereGLOBAL:
8370 assert (!ffecom_transform_only_dummies_);
8372 t = build_decl (FUNCTION_DECL,
8373 ffecom_get_external_identifier_ (s),
8374 ffecom_tree_blockdata_type);
8375 DECL_EXTERNAL (t) = 1;
8376 TREE_PUBLIC (t) = 1;
8378 t = start_decl (t, FALSE);
8379 finish_decl (t, NULL_TREE, FALSE);
8381 ffecom_save_tree_forever (t);
8385 case FFEINFO_whereCOMMON:
8386 case FFEINFO_whereDUMMY:
8387 case FFEINFO_whereRESULT:
8388 case FFEINFO_whereFLEETING:
8389 case FFEINFO_whereFLEETING_CADDR:
8390 case FFEINFO_whereFLEETING_IADDR:
8391 case FFEINFO_whereIMMEDIATE:
8392 case FFEINFO_whereINTRINSIC:
8393 case FFEINFO_whereCONSTANT:
8394 case FFEINFO_whereCONSTANT_SUBOBJECT:
8396 assert ("BLOCKDATA where unheard of" == NULL);
8398 case FFEINFO_whereANY:
8399 t = error_mark_node;
8404 case FFEINFO_kindCOMMON:
8405 switch (ffeinfo_where (ffesymbol_info (s)))
8407 case FFEINFO_whereLOCAL:
8408 assert (!ffecom_transform_only_dummies_);
8409 ffecom_transform_common_ (s);
8412 case FFEINFO_whereNONE:
8413 case FFEINFO_whereCOMMON:
8414 case FFEINFO_whereDUMMY:
8415 case FFEINFO_whereGLOBAL:
8416 case FFEINFO_whereRESULT:
8417 case FFEINFO_whereFLEETING:
8418 case FFEINFO_whereFLEETING_CADDR:
8419 case FFEINFO_whereFLEETING_IADDR:
8420 case FFEINFO_whereIMMEDIATE:
8421 case FFEINFO_whereINTRINSIC:
8422 case FFEINFO_whereCONSTANT:
8423 case FFEINFO_whereCONSTANT_SUBOBJECT:
8425 assert ("COMMON where unheard of" == NULL);
8427 case FFEINFO_whereANY:
8428 t = error_mark_node;
8433 case FFEINFO_kindCONSTRUCT:
8434 switch (ffeinfo_where (ffesymbol_info (s)))
8436 case FFEINFO_whereLOCAL:
8437 assert (!ffecom_transform_only_dummies_);
8440 case FFEINFO_whereNONE:
8441 case FFEINFO_whereCOMMON:
8442 case FFEINFO_whereDUMMY:
8443 case FFEINFO_whereGLOBAL:
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 ("CONSTRUCT where unheard of" == NULL);
8455 case FFEINFO_whereANY:
8456 t = error_mark_node;
8461 case FFEINFO_kindNAMELIST:
8462 switch (ffeinfo_where (ffesymbol_info (s)))
8464 case FFEINFO_whereLOCAL:
8465 assert (!ffecom_transform_only_dummies_);
8466 t = ffecom_transform_namelist_ (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 ("NAMELIST where unheard of" == NULL);
8484 case FFEINFO_whereANY:
8485 t = error_mark_node;
8491 assert ("kind unheard of" == NULL);
8493 case FFEINFO_kindANY:
8494 t = error_mark_node;
8498 ffesymbol_hook (s).decl_tree = t;
8499 ffesymbol_hook (s).length_tree = tlen;
8500 ffesymbol_hook (s).addr = addr;
8502 lineno = old_lineno;
8503 input_filename = old_input_filename;
8509 /* Transform into ASSIGNable symbol.
8511 Symbol has already been transformed, but for whatever reason, the
8512 resulting decl_tree has been deemed not usable for an ASSIGN target.
8513 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8514 another local symbol of type void * and stuff that in the assign_tree
8515 argument. The F77/F90 standards allow this implementation. */
8517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8519 ffecom_sym_transform_assign_ (ffesymbol s)
8521 tree t; /* Transformed thingy. */
8522 int old_lineno = lineno;
8523 const char *old_input_filename = input_filename;
8525 if (ffesymbol_sfdummyparent (s) == NULL)
8527 input_filename = ffesymbol_where_filename (s);
8528 lineno = ffesymbol_where_filelinenum (s);
8532 ffesymbol sf = ffesymbol_sfdummyparent (s);
8534 input_filename = ffesymbol_where_filename (sf);
8535 lineno = ffesymbol_where_filelinenum (sf);
8538 assert (!ffecom_transform_only_dummies_);
8540 t = build_decl (VAR_DECL,
8541 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8542 ffesymbol_text (s)),
8543 TREE_TYPE (null_pointer_node));
8545 switch (ffesymbol_where (s))
8547 case FFEINFO_whereLOCAL:
8548 /* Unlike for regular vars, SAVE status is easy to determine for
8549 ASSIGNed vars, since there's no initialization, there's no
8550 effective storage association (so "SAVE J" does not apply to
8551 K even given "EQUIVALENCE (J,K)"), there's no size issue
8552 to worry about, etc. */
8553 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8554 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8555 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8556 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8558 TREE_STATIC (t) = 0; /* No need to make static. */
8561 case FFEINFO_whereCOMMON:
8562 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8565 case FFEINFO_whereDUMMY:
8566 /* Note that twinning a DUMMY means the caller won't see
8567 the ASSIGNed value. But both F77 and F90 allow implementations
8568 to do this, i.e. disallow Fortran code that would try and
8569 take advantage of actually putting a label into a variable
8570 via a dummy argument (or any other storage association, for
8572 TREE_STATIC (t) = 0;
8576 TREE_STATIC (t) = 0;
8580 t = start_decl (t, FALSE);
8581 finish_decl (t, NULL_TREE, FALSE);
8583 ffesymbol_hook (s).assign_tree = t;
8585 lineno = old_lineno;
8586 input_filename = old_input_filename;
8592 /* Implement COMMON area in back end.
8594 Because COMMON-based variables can be referenced in the dimension
8595 expressions of dummy (adjustable) arrays, and because dummies
8596 (in the gcc back end) need to be put in the outer binding level
8597 of a function (which has two binding levels, the outer holding
8598 the dummies and the inner holding the other vars), special care
8599 must be taken to handle COMMON areas.
8601 The current strategy is basically to always tell the back end about
8602 the COMMON area as a top-level external reference to just a block
8603 of storage of the master type of that area (e.g. integer, real,
8604 character, whatever -- not a structure). As a distinct action,
8605 if initial values are provided, tell the back end about the area
8606 as a top-level non-external (initialized) area and remember not to
8607 allow further initialization or expansion of the area. Meanwhile,
8608 if no initialization happens at all, tell the back end about
8609 the largest size we've seen declared so the space does get reserved.
8610 (This function doesn't handle all that stuff, but it does some
8611 of the important things.)
8613 Meanwhile, for COMMON variables themselves, just keep creating
8614 references like *((float *) (&common_area + offset)) each time
8615 we reference the variable. In other words, don't make a VAR_DECL
8616 or any kind of component reference (like we used to do before 0.4),
8617 though we might do that as well just for debugging purposes (and
8618 stuff the rtl with the appropriate offset expression). */
8620 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8622 ffecom_transform_common_ (ffesymbol s)
8624 ffestorag st = ffesymbol_storage (s);
8625 ffeglobal g = ffesymbol_global (s);
8630 bool is_init = ffestorag_is_init (st);
8632 assert (st != NULL);
8635 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8638 /* First update the size of the area in global terms. */
8640 ffeglobal_size_common (s, ffestorag_size (st));
8642 if (!ffeglobal_common_init (g))
8643 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
8645 cbt = ffeglobal_hook (g);
8647 /* If we already have declared this common block for a previous program
8648 unit, and either we already initialized it or we don't have new
8649 initialization for it, just return what we have without changing it. */
8651 if ((cbt != NULL_TREE)
8653 || !DECL_EXTERNAL (cbt)))
8655 if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8659 /* Process inits. */
8663 if (ffestorag_init (st) != NULL)
8667 /* Set the padding for the expression, so ffecom_expr
8668 knows to insert that many zeros. */
8669 switch (ffebld_op (sexp = ffestorag_init (st)))
8671 case FFEBLD_opCONTER:
8672 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8675 case FFEBLD_opARRTER:
8676 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8679 case FFEBLD_opACCTER:
8680 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8684 assert ("bad op for cmn init (pad)" == NULL);
8688 init = ffecom_expr (sexp);
8689 if (init == error_mark_node)
8690 { /* Hopefully the back end complained! */
8692 if (cbt != NULL_TREE)
8697 init = error_mark_node;
8702 /* cbtype must be permanently allocated! */
8704 /* Allocate the MAX of the areas so far, seen filewide. */
8705 high = build_int_2 ((ffeglobal_common_size (g)
8706 + ffeglobal_common_pad (g)) - 1, 0);
8707 TREE_TYPE (high) = ffecom_integer_type_node;
8710 cbtype = build_array_type (char_type_node,
8711 build_range_type (integer_type_node,
8715 cbtype = build_array_type (char_type_node, NULL_TREE);
8717 if (cbt == NULL_TREE)
8720 = build_decl (VAR_DECL,
8721 ffecom_get_external_identifier_ (s),
8723 TREE_STATIC (cbt) = 1;
8724 TREE_PUBLIC (cbt) = 1;
8729 TREE_TYPE (cbt) = cbtype;
8731 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8732 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8734 cbt = start_decl (cbt, TRUE);
8735 if (ffeglobal_hook (g) != NULL)
8736 assert (cbt == ffeglobal_hook (g));
8738 assert (!init || !DECL_EXTERNAL (cbt));
8740 /* Make sure that any type can live in COMMON and be referenced
8741 without getting a bus error. We could pick the most restrictive
8742 alignment of all entities actually placed in the COMMON, but
8743 this seems easy enough. */
8745 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8746 DECL_USER_ALIGN (cbt) = 0;
8748 if (is_init && (ffestorag_init (st) == NULL))
8749 init = ffecom_init_zero_ (cbt);
8751 finish_decl (cbt, init, TRUE);
8754 ffestorag_set_init (st, ffebld_new_any ());
8758 assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8759 assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8760 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8761 (ffeglobal_common_size (g)
8762 + ffeglobal_common_pad (g))));
8765 ffeglobal_set_hook (g, cbt);
8767 ffestorag_set_hook (st, cbt);
8769 ffecom_save_tree_forever (cbt);
8773 /* Make master area for local EQUIVALENCE. */
8775 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8777 ffecom_transform_equiv_ (ffestorag eqst)
8783 bool is_init = ffestorag_is_init (eqst);
8785 assert (eqst != NULL);
8787 eqt = ffestorag_hook (eqst);
8789 if (eqt != NULL_TREE)
8792 /* Process inits. */
8796 if (ffestorag_init (eqst) != NULL)
8800 /* Set the padding for the expression, so ffecom_expr
8801 knows to insert that many zeros. */
8802 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8804 case FFEBLD_opCONTER:
8805 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8808 case FFEBLD_opARRTER:
8809 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8812 case FFEBLD_opACCTER:
8813 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8817 assert ("bad op for eqv init (pad)" == NULL);
8821 init = ffecom_expr (sexp);
8822 if (init == error_mark_node)
8823 init = NULL_TREE; /* Hopefully the back end complained! */
8826 init = error_mark_node;
8828 else if (ffe_is_init_local_zero ())
8829 init = error_mark_node;
8833 ffecom_member_namelisted_ = FALSE;
8834 ffestorag_drive (ffestorag_list_equivs (eqst),
8835 &ffecom_member_phase1_,
8838 high = build_int_2 ((ffestorag_size (eqst)
8839 + ffestorag_modulo (eqst)) - 1, 0);
8840 TREE_TYPE (high) = ffecom_integer_type_node;
8842 eqtype = build_array_type (char_type_node,
8843 build_range_type (ffecom_integer_type_node,
8844 ffecom_integer_zero_node,
8847 eqt = build_decl (VAR_DECL,
8848 ffecom_get_invented_identifier ("__g77_equiv_%s",
8850 (ffestorag_symbol (eqst))),
8852 DECL_EXTERNAL (eqt) = 0;
8854 || ffecom_member_namelisted_
8855 #ifdef FFECOM_sizeMAXSTACKITEM
8856 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8858 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8859 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8860 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8861 TREE_STATIC (eqt) = 1;
8863 TREE_STATIC (eqt) = 0;
8864 TREE_PUBLIC (eqt) = 0;
8865 TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
8866 DECL_CONTEXT (eqt) = current_function_decl;
8868 DECL_INITIAL (eqt) = error_mark_node;
8870 DECL_INITIAL (eqt) = NULL_TREE;
8872 eqt = start_decl (eqt, FALSE);
8874 /* Make sure that any type can live in EQUIVALENCE and be referenced
8875 without getting a bus error. We could pick the most restrictive
8876 alignment of all entities actually placed in the EQUIVALENCE, but
8877 this seems easy enough. */
8879 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8880 DECL_USER_ALIGN (eqt) = 0;
8882 if ((!is_init && ffe_is_init_local_zero ())
8883 || (is_init && (ffestorag_init (eqst) == NULL)))
8884 init = ffecom_init_zero_ (eqt);
8886 finish_decl (eqt, init, FALSE);
8889 ffestorag_set_init (eqst, ffebld_new_any ());
8892 assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8893 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8894 (ffestorag_size (eqst)
8895 + ffestorag_modulo (eqst))));
8898 ffestorag_set_hook (eqst, eqt);
8900 ffestorag_drive (ffestorag_list_equivs (eqst),
8901 &ffecom_member_phase2_,
8906 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8910 ffecom_transform_namelist_ (ffesymbol s)
8913 tree nmltype = ffecom_type_namelist_ ();
8921 static int mynumber = 0;
8923 nmlt = build_decl (VAR_DECL,
8924 ffecom_get_invented_identifier ("__g77_namelist_%d",
8927 TREE_STATIC (nmlt) = 1;
8928 DECL_INITIAL (nmlt) = error_mark_node;
8930 nmlt = start_decl (nmlt, FALSE);
8932 /* Process inits. */
8934 i = strlen (ffesymbol_text (s));
8936 high = build_int_2 (i, 0);
8937 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8939 nameinit = ffecom_build_f2c_string_ (i + 1,
8940 ffesymbol_text (s));
8941 TREE_TYPE (nameinit)
8942 = build_type_variant
8945 build_range_type (ffecom_f2c_ftnlen_type_node,
8946 ffecom_f2c_ftnlen_one_node,
8949 TREE_CONSTANT (nameinit) = 1;
8950 TREE_STATIC (nameinit) = 1;
8951 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8954 varsinit = ffecom_vardesc_array_ (s);
8955 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8957 TREE_CONSTANT (varsinit) = 1;
8958 TREE_STATIC (varsinit) = 1;
8963 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8966 nvarsinit = build_int_2 (i, 0);
8967 TREE_TYPE (nvarsinit) = integer_type_node;
8968 TREE_CONSTANT (nvarsinit) = 1;
8969 TREE_STATIC (nvarsinit) = 1;
8971 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8972 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8974 TREE_CHAIN (TREE_CHAIN (nmlinits))
8975 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8977 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8978 TREE_CONSTANT (nmlinits) = 1;
8979 TREE_STATIC (nmlinits) = 1;
8981 finish_decl (nmlt, nmlinits, FALSE);
8983 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8990 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8991 analyzed on the assumption it is calculating a pointer to be
8992 indirected through. It must return the proper decl and offset,
8993 taking into account different units of measurements for offsets. */
8995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8997 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9000 switch (TREE_CODE (t))
9004 case NON_LVALUE_EXPR:
9005 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9009 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9010 if ((*decl == NULL_TREE)
9011 || (*decl == error_mark_node))
9014 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9016 /* An offset into COMMON. */
9017 *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9018 *offset, TREE_OPERAND (t, 1)));
9019 /* Convert offset (presumably in bytes) into canonical units
9020 (presumably bits). */
9021 *offset = size_binop (MULT_EXPR,
9022 convert (bitsizetype, *offset),
9023 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9026 /* Not a COMMON reference, so an unrecognized pattern. */
9027 *decl = error_mark_node;
9032 *offset = bitsize_zero_node;
9036 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9038 /* A reference to COMMON. */
9039 *decl = TREE_OPERAND (t, 0);
9040 *offset = bitsize_zero_node;
9045 /* Not a COMMON reference, so an unrecognized pattern. */
9046 *decl = error_mark_node;
9052 /* Given a tree that is possibly intended for use as an lvalue, return
9053 information representing a canonical view of that tree as a decl, an
9054 offset into that decl, and a size for the lvalue.
9056 If there's no applicable decl, NULL_TREE is returned for the decl,
9057 and the other fields are left undefined.
9059 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9060 is returned for the decl, and the other fields are left undefined.
9062 Otherwise, the decl returned currently is either a VAR_DECL or a
9065 The offset returned is always valid, but of course not necessarily
9066 a constant, and not necessarily converted into the appropriate
9067 type, leaving that up to the caller (so as to avoid that overhead
9068 if the decls being looked at are different anyway).
9070 If the size cannot be determined (e.g. an adjustable array),
9071 an ERROR_MARK node is returned for the size. Otherwise, the
9072 size returned is valid, not necessarily a constant, and not
9073 necessarily converted into the appropriate type as with the
9076 Note that the offset and size expressions are expressed in the
9077 base storage units (usually bits) rather than in the units of
9078 the type of the decl, because two decls with different types
9079 might overlap but with apparently non-overlapping array offsets,
9080 whereas converting the array offsets to consistant offsets will
9081 reveal the overlap. */
9083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9085 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9088 /* The default path is to report a nonexistant decl. */
9094 switch (TREE_CODE (t))
9097 case IDENTIFIER_NODE:
9106 case TRUNC_DIV_EXPR:
9108 case FLOOR_DIV_EXPR:
9109 case ROUND_DIV_EXPR:
9110 case TRUNC_MOD_EXPR:
9112 case FLOOR_MOD_EXPR:
9113 case ROUND_MOD_EXPR:
9115 case EXACT_DIV_EXPR:
9116 case FIX_TRUNC_EXPR:
9118 case FIX_FLOOR_EXPR:
9119 case FIX_ROUND_EXPR:
9134 case BIT_ANDTC_EXPR:
9136 case TRUTH_ANDIF_EXPR:
9137 case TRUTH_ORIF_EXPR:
9138 case TRUTH_AND_EXPR:
9140 case TRUTH_XOR_EXPR:
9141 case TRUTH_NOT_EXPR:
9161 *offset = bitsize_zero_node;
9162 *size = TYPE_SIZE (TREE_TYPE (t));
9167 tree array = TREE_OPERAND (t, 0);
9168 tree element = TREE_OPERAND (t, 1);
9171 if ((array == NULL_TREE)
9172 || (element == NULL_TREE))
9174 *decl = error_mark_node;
9178 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9180 if ((*decl == NULL_TREE)
9181 || (*decl == error_mark_node))
9184 /* Calculate ((element - base) * NBBY) + init_offset. */
9185 *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9187 TYPE_MIN_VALUE (TYPE_DOMAIN
9188 (TREE_TYPE (array)))));
9190 *offset = size_binop (MULT_EXPR,
9191 convert (bitsizetype, *offset),
9192 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9194 *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9196 *size = TYPE_SIZE (TREE_TYPE (t));
9202 /* Most of this code is to handle references to COMMON. And so
9203 far that is useful only for calling library functions, since
9204 external (user) functions might reference common areas. But
9205 even calling an external function, it's worthwhile to decode
9206 COMMON references because if not storing into COMMON, we don't
9207 want COMMON-based arguments to gratuitously force use of a
9210 *size = TYPE_SIZE (TREE_TYPE (t));
9212 ffecom_tree_canonize_ptr_ (decl, offset,
9213 TREE_OPERAND (t, 0));
9220 case NON_LVALUE_EXPR:
9223 case COND_EXPR: /* More cases than we can handle. */
9225 case REFERENCE_EXPR:
9226 case PREDECREMENT_EXPR:
9227 case PREINCREMENT_EXPR:
9228 case POSTDECREMENT_EXPR:
9229 case POSTINCREMENT_EXPR:
9232 *decl = error_mark_node;
9238 /* Do divide operation appropriate to type of operands. */
9240 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9242 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9243 tree dest_tree, ffebld dest, bool *dest_used,
9246 if ((left == error_mark_node)
9247 || (right == error_mark_node))
9248 return error_mark_node;
9250 switch (TREE_CODE (tree_type))
9253 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9258 if (! optimize_size)
9259 return ffecom_2 (RDIV_EXPR, tree_type,
9265 if (TREE_TYPE (tree_type)
9266 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9267 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9269 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9271 left = ffecom_1 (ADDR_EXPR,
9272 build_pointer_type (TREE_TYPE (left)),
9274 left = build_tree_list (NULL_TREE, left);
9275 right = ffecom_1 (ADDR_EXPR,
9276 build_pointer_type (TREE_TYPE (right)),
9278 right = build_tree_list (NULL_TREE, right);
9279 TREE_CHAIN (left) = right;
9281 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9282 ffecom_gfrt_kindtype (ix),
9283 ffe_is_f2c_library (),
9286 dest_tree, dest, dest_used,
9287 NULL_TREE, TRUE, hook);
9295 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9296 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9297 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9299 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9301 left = ffecom_1 (ADDR_EXPR,
9302 build_pointer_type (TREE_TYPE (left)),
9304 left = build_tree_list (NULL_TREE, left);
9305 right = ffecom_1 (ADDR_EXPR,
9306 build_pointer_type (TREE_TYPE (right)),
9308 right = build_tree_list (NULL_TREE, right);
9309 TREE_CHAIN (left) = right;
9311 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9312 ffecom_gfrt_kindtype (ix),
9313 ffe_is_f2c_library (),
9316 dest_tree, dest, dest_used,
9317 NULL_TREE, TRUE, hook);
9322 return ffecom_2 (RDIV_EXPR, tree_type,
9329 /* Build type info for non-dummy variable. */
9331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9333 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9342 type = ffecom_tree_type[bt][kt];
9343 if (bt == FFEINFO_basictypeCHARACTER)
9345 hight = build_int_2 (ffesymbol_size (s), 0);
9346 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9351 build_range_type (ffecom_f2c_ftnlen_type_node,
9352 ffecom_f2c_ftnlen_one_node,
9354 type = ffecom_check_size_overflow_ (s, type, FALSE);
9357 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9359 if (type == error_mark_node)
9362 dim = ffebld_head (dl);
9363 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9365 if (ffebld_left (dim) == NULL)
9366 lowt = integer_one_node;
9368 lowt = ffecom_expr (ffebld_left (dim));
9370 if (TREE_CODE (lowt) != INTEGER_CST)
9371 lowt = variable_size (lowt);
9373 assert (ffebld_right (dim) != NULL);
9374 hight = ffecom_expr (ffebld_right (dim));
9376 if (TREE_CODE (hight) != INTEGER_CST)
9377 hight = variable_size (hight);
9379 type = build_array_type (type,
9380 build_range_type (ffecom_integer_type_node,
9382 type = ffecom_check_size_overflow_ (s, type, FALSE);
9389 /* Build Namelist type. */
9391 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9393 ffecom_type_namelist_ ()
9395 static tree type = NULL_TREE;
9397 if (type == NULL_TREE)
9399 static tree namefield, varsfield, nvarsfield;
9402 vardesctype = ffecom_type_vardesc_ ();
9404 type = make_node (RECORD_TYPE);
9406 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9408 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9410 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9411 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9414 TYPE_FIELDS (type) = namefield;
9417 ggc_add_tree_root (&type, 1);
9425 /* Build Vardesc type. */
9427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9429 ffecom_type_vardesc_ ()
9431 static tree type = NULL_TREE;
9432 static tree namefield, addrfield, dimsfield, typefield;
9434 if (type == NULL_TREE)
9436 type = make_node (RECORD_TYPE);
9438 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9440 addrfield = ffecom_decl_field (type, namefield, "addr",
9442 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9443 ffecom_f2c_ptr_to_ftnlen_type_node);
9444 typefield = ffecom_decl_field (type, dimsfield, "type",
9447 TYPE_FIELDS (type) = namefield;
9450 ggc_add_tree_root (&type, 1);
9458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9460 ffecom_vardesc_ (ffebld expr)
9464 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9465 s = ffebld_symter (expr);
9467 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9470 tree vardesctype = ffecom_type_vardesc_ ();
9478 static int mynumber = 0;
9480 var = build_decl (VAR_DECL,
9481 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9484 TREE_STATIC (var) = 1;
9485 DECL_INITIAL (var) = error_mark_node;
9487 var = start_decl (var, FALSE);
9489 /* Process inits. */
9491 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9493 ffesymbol_text (s));
9494 TREE_TYPE (nameinit)
9495 = build_type_variant
9498 build_range_type (integer_type_node,
9500 build_int_2 (i, 0))),
9502 TREE_CONSTANT (nameinit) = 1;
9503 TREE_STATIC (nameinit) = 1;
9504 nameinit = ffecom_1 (ADDR_EXPR,
9505 build_pointer_type (TREE_TYPE (nameinit)),
9508 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9510 dimsinit = ffecom_vardesc_dims_ (s);
9512 if (typeinit == NULL_TREE)
9514 ffeinfoBasictype bt = ffesymbol_basictype (s);
9515 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9516 int tc = ffecom_f2c_typecode (bt, kt);
9519 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9522 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9524 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9526 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9528 TREE_CHAIN (TREE_CHAIN (varinits))
9529 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9530 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9531 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9533 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9534 TREE_CONSTANT (varinits) = 1;
9535 TREE_STATIC (varinits) = 1;
9537 finish_decl (var, varinits, FALSE);
9539 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9541 ffesymbol_hook (s).vardesc_tree = var;
9544 return ffesymbol_hook (s).vardesc_tree;
9548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9550 ffecom_vardesc_array_ (ffesymbol s)
9554 tree item = NULL_TREE;
9557 static int mynumber = 0;
9559 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9561 b = ffebld_trail (b), ++i)
9565 t = ffecom_vardesc_ (ffebld_head (b));
9567 if (list == NULL_TREE)
9568 list = item = build_tree_list (NULL_TREE, t);
9571 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9572 item = TREE_CHAIN (item);
9576 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9577 build_range_type (integer_type_node,
9579 build_int_2 (i, 0)));
9580 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9581 TREE_CONSTANT (list) = 1;
9582 TREE_STATIC (list) = 1;
9584 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9585 var = build_decl (VAR_DECL, var, item);
9586 TREE_STATIC (var) = 1;
9587 DECL_INITIAL (var) = error_mark_node;
9588 var = start_decl (var, FALSE);
9589 finish_decl (var, list, FALSE);
9595 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9597 ffecom_vardesc_dims_ (ffesymbol s)
9599 if (ffesymbol_dims (s) == NULL)
9600 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9608 tree item = NULL_TREE;
9612 tree baseoff = NULL_TREE;
9613 static int mynumber = 0;
9615 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9616 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9618 numelem = ffecom_expr (ffesymbol_arraysize (s));
9619 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9622 backlist = NULL_TREE;
9623 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9625 b = ffebld_trail (b), e = ffebld_trail (e))
9631 if (ffebld_trail (b) == NULL)
9635 t = convert (ffecom_f2c_ftnlen_type_node,
9636 ffecom_expr (ffebld_head (e)));
9638 if (list == NULL_TREE)
9639 list = item = build_tree_list (NULL_TREE, t);
9642 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9643 item = TREE_CHAIN (item);
9647 if (ffebld_left (ffebld_head (b)) == NULL)
9648 low = ffecom_integer_one_node;
9650 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9651 low = convert (ffecom_f2c_ftnlen_type_node, low);
9653 back = build_tree_list (low, t);
9654 TREE_CHAIN (back) = backlist;
9658 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9660 if (TREE_VALUE (item) == NULL_TREE)
9661 baseoff = TREE_PURPOSE (item);
9663 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9664 TREE_PURPOSE (item),
9665 ffecom_2 (MULT_EXPR,
9666 ffecom_f2c_ftnlen_type_node,
9671 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9673 baseoff = build_tree_list (NULL_TREE, baseoff);
9674 TREE_CHAIN (baseoff) = list;
9676 numelem = build_tree_list (NULL_TREE, numelem);
9677 TREE_CHAIN (numelem) = baseoff;
9679 numdim = build_tree_list (NULL_TREE, numdim);
9680 TREE_CHAIN (numdim) = numelem;
9682 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9683 build_range_type (integer_type_node,
9686 ((int) ffesymbol_rank (s)
9688 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9689 TREE_CONSTANT (list) = 1;
9690 TREE_STATIC (list) = 1;
9692 var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9693 var = build_decl (VAR_DECL, var, item);
9694 TREE_STATIC (var) = 1;
9695 DECL_INITIAL (var) = error_mark_node;
9696 var = start_decl (var, FALSE);
9697 finish_decl (var, list, FALSE);
9699 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9706 /* Essentially does a "fold (build1 (code, type, node))" while checking
9707 for certain housekeeping things.
9709 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9710 ffecom_1_fn instead. */
9712 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9714 ffecom_1 (enum tree_code code, tree type, tree node)
9718 if ((node == error_mark_node)
9719 || (type == error_mark_node))
9720 return error_mark_node;
9722 if (code == ADDR_EXPR)
9724 if (!mark_addressable (node))
9725 assert ("can't mark_addressable this node!" == NULL);
9728 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9733 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9737 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9742 if (TREE_CODE (type) != RECORD_TYPE)
9744 item = build1 (code, type, node);
9747 node = ffecom_stabilize_aggregate_ (node);
9748 realtype = TREE_TYPE (TYPE_FIELDS (type));
9750 ffecom_2 (COMPLEX_EXPR, type,
9751 ffecom_1 (NEGATE_EXPR, realtype,
9752 ffecom_1 (REALPART_EXPR, realtype,
9754 ffecom_1 (NEGATE_EXPR, realtype,
9755 ffecom_1 (IMAGPART_EXPR, realtype,
9760 item = build1 (code, type, node);
9764 if (TREE_SIDE_EFFECTS (node))
9765 TREE_SIDE_EFFECTS (item) = 1;
9766 if ((code == ADDR_EXPR) && staticp (node))
9767 TREE_CONSTANT (item) = 1;
9772 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9773 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9774 does not set TREE_ADDRESSABLE (because calling an inline
9775 function does not mean the function needs to be separately
9778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9780 ffecom_1_fn (tree node)
9785 if (node == error_mark_node)
9786 return error_mark_node;
9788 type = build_type_variant (TREE_TYPE (node),
9789 TREE_READONLY (node),
9790 TREE_THIS_VOLATILE (node));
9791 item = build1 (ADDR_EXPR,
9792 build_pointer_type (type), node);
9793 if (TREE_SIDE_EFFECTS (node))
9794 TREE_SIDE_EFFECTS (item) = 1;
9796 TREE_CONSTANT (item) = 1;
9801 /* Essentially does a "fold (build (code, type, node1, node2))" while
9802 checking for certain housekeeping things. */
9804 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9806 ffecom_2 (enum tree_code code, tree type, tree node1,
9811 if ((node1 == error_mark_node)
9812 || (node2 == error_mark_node)
9813 || (type == error_mark_node))
9814 return error_mark_node;
9816 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9818 tree a, b, c, d, realtype;
9821 assert ("no CONJ_EXPR support yet" == NULL);
9822 return error_mark_node;
9825 item = build_tree_list (TYPE_FIELDS (type), node1);
9826 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9827 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9831 if (TREE_CODE (type) != RECORD_TYPE)
9833 item = build (code, type, node1, node2);
9836 node1 = ffecom_stabilize_aggregate_ (node1);
9837 node2 = ffecom_stabilize_aggregate_ (node2);
9838 realtype = TREE_TYPE (TYPE_FIELDS (type));
9840 ffecom_2 (COMPLEX_EXPR, type,
9841 ffecom_2 (PLUS_EXPR, realtype,
9842 ffecom_1 (REALPART_EXPR, realtype,
9844 ffecom_1 (REALPART_EXPR, realtype,
9846 ffecom_2 (PLUS_EXPR, realtype,
9847 ffecom_1 (IMAGPART_EXPR, realtype,
9849 ffecom_1 (IMAGPART_EXPR, realtype,
9854 if (TREE_CODE (type) != RECORD_TYPE)
9856 item = build (code, type, node1, node2);
9859 node1 = ffecom_stabilize_aggregate_ (node1);
9860 node2 = ffecom_stabilize_aggregate_ (node2);
9861 realtype = TREE_TYPE (TYPE_FIELDS (type));
9863 ffecom_2 (COMPLEX_EXPR, type,
9864 ffecom_2 (MINUS_EXPR, realtype,
9865 ffecom_1 (REALPART_EXPR, realtype,
9867 ffecom_1 (REALPART_EXPR, realtype,
9869 ffecom_2 (MINUS_EXPR, realtype,
9870 ffecom_1 (IMAGPART_EXPR, realtype,
9872 ffecom_1 (IMAGPART_EXPR, realtype,
9877 if (TREE_CODE (type) != RECORD_TYPE)
9879 item = build (code, type, node1, node2);
9882 node1 = ffecom_stabilize_aggregate_ (node1);
9883 node2 = ffecom_stabilize_aggregate_ (node2);
9884 realtype = TREE_TYPE (TYPE_FIELDS (type));
9885 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9887 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9889 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9891 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9894 ffecom_2 (COMPLEX_EXPR, type,
9895 ffecom_2 (MINUS_EXPR, realtype,
9896 ffecom_2 (MULT_EXPR, realtype,
9899 ffecom_2 (MULT_EXPR, realtype,
9902 ffecom_2 (PLUS_EXPR, realtype,
9903 ffecom_2 (MULT_EXPR, realtype,
9906 ffecom_2 (MULT_EXPR, realtype,
9912 if ((TREE_CODE (node1) != RECORD_TYPE)
9913 && (TREE_CODE (node2) != RECORD_TYPE))
9915 item = build (code, type, node1, node2);
9918 assert (TREE_CODE (node1) == RECORD_TYPE);
9919 assert (TREE_CODE (node2) == RECORD_TYPE);
9920 node1 = ffecom_stabilize_aggregate_ (node1);
9921 node2 = ffecom_stabilize_aggregate_ (node2);
9922 realtype = TREE_TYPE (TYPE_FIELDS (type));
9924 ffecom_2 (TRUTH_ANDIF_EXPR, type,
9925 ffecom_2 (code, type,
9926 ffecom_1 (REALPART_EXPR, realtype,
9928 ffecom_1 (REALPART_EXPR, realtype,
9930 ffecom_2 (code, type,
9931 ffecom_1 (IMAGPART_EXPR, realtype,
9933 ffecom_1 (IMAGPART_EXPR, realtype,
9938 if ((TREE_CODE (node1) != RECORD_TYPE)
9939 && (TREE_CODE (node2) != RECORD_TYPE))
9941 item = build (code, type, node1, node2);
9944 assert (TREE_CODE (node1) == RECORD_TYPE);
9945 assert (TREE_CODE (node2) == RECORD_TYPE);
9946 node1 = ffecom_stabilize_aggregate_ (node1);
9947 node2 = ffecom_stabilize_aggregate_ (node2);
9948 realtype = TREE_TYPE (TYPE_FIELDS (type));
9950 ffecom_2 (TRUTH_ORIF_EXPR, type,
9951 ffecom_2 (code, type,
9952 ffecom_1 (REALPART_EXPR, realtype,
9954 ffecom_1 (REALPART_EXPR, realtype,
9956 ffecom_2 (code, type,
9957 ffecom_1 (IMAGPART_EXPR, realtype,
9959 ffecom_1 (IMAGPART_EXPR, realtype,
9964 item = build (code, type, node1, node2);
9968 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9969 TREE_SIDE_EFFECTS (item) = 1;
9974 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9976 ffesymbol s; // the ENTRY point itself
9977 if (ffecom_2pass_advise_entrypoint(s))
9978 // the ENTRY point has been accepted
9980 Does whatever compiler needs to do when it learns about the entrypoint,
9981 like determine the return type of the master function, count the
9982 number of entrypoints, etc. Returns FALSE if the return type is
9983 not compatible with the return type(s) of other entrypoint(s).
9985 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9986 later (after _finish_progunit) be called with the same entrypoint(s)
9987 as passed to this fn for which TRUE was returned.
9990 Return FALSE if the return type conflicts with previous entrypoints. */
9992 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9994 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9996 ffebld list; /* opITEM. */
9997 ffebld mlist; /* opITEM. */
9998 ffebld plist; /* opITEM. */
9999 ffebld arg; /* ffebld_head(opITEM). */
10000 ffebld item; /* opITEM. */
10001 ffesymbol s; /* ffebld_symter(arg). */
10002 ffeinfoBasictype bt = ffesymbol_basictype (entry);
10003 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10004 ffetargetCharacterSize size = ffesymbol_size (entry);
10007 if (ffecom_num_entrypoints_ == 0)
10008 { /* First entrypoint, make list of main
10009 arglist's dummies. */
10010 assert (ffecom_primary_entry_ != NULL);
10012 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10013 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10014 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10016 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10018 list = ffebld_trail (list))
10020 arg = ffebld_head (list);
10021 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10022 continue; /* Alternate return or some such thing. */
10023 item = ffebld_new_item (arg, NULL);
10025 ffecom_master_arglist_ = item;
10027 ffebld_set_trail (plist, item);
10032 /* If necessary, scan entry arglist for alternate returns. Do this scan
10033 apparently redundantly (it's done below to UNIONize the arglists) so
10034 that we don't complain about RETURN 1 if an offending ENTRY is the only
10035 one with an alternate return. */
10037 if (!ffecom_is_altreturning_)
10039 for (list = ffesymbol_dummyargs (entry);
10041 list = ffebld_trail (list))
10043 arg = ffebld_head (list);
10044 if (ffebld_op (arg) == FFEBLD_opSTAR)
10046 ffecom_is_altreturning_ = TRUE;
10052 /* Now check type compatibility. */
10054 switch (ffecom_master_bt_)
10056 case FFEINFO_basictypeNONE:
10057 ok = (bt != FFEINFO_basictypeCHARACTER);
10060 case FFEINFO_basictypeCHARACTER:
10062 = (bt == FFEINFO_basictypeCHARACTER)
10063 && (kt == ffecom_master_kt_)
10064 && (size == ffecom_master_size_);
10067 case FFEINFO_basictypeANY:
10068 return FALSE; /* Just don't bother. */
10071 if (bt == FFEINFO_basictypeCHARACTER)
10077 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10079 ffecom_master_bt_ = FFEINFO_basictypeNONE;
10080 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10087 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10088 ffest_ffebad_here_current_stmt (0);
10090 return FALSE; /* Can't handle entrypoint. */
10093 /* Entrypoint type compatible with previous types. */
10095 ++ffecom_num_entrypoints_;
10097 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10099 for (list = ffesymbol_dummyargs (entry);
10101 list = ffebld_trail (list))
10103 arg = ffebld_head (list);
10104 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10105 continue; /* Alternate return or some such thing. */
10106 s = ffebld_symter (arg);
10107 for (plist = NULL, mlist = ffecom_master_arglist_;
10109 plist = mlist, mlist = ffebld_trail (mlist))
10110 { /* plist points to previous item for easy
10111 appending of arg. */
10112 if (ffebld_symter (ffebld_head (mlist)) == s)
10113 break; /* Already have this arg in the master list. */
10116 continue; /* Already have this arg in the master list. */
10118 /* Append this arg to the master list. */
10120 item = ffebld_new_item (arg, NULL);
10122 ffecom_master_arglist_ = item;
10124 ffebld_set_trail (plist, item);
10131 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10133 ffesymbol s; // the ENTRY point itself
10134 ffecom_2pass_do_entrypoint(s);
10136 Does whatever compiler needs to do to make the entrypoint actually
10137 happen. Must be called for each entrypoint after
10138 ffecom_finish_progunit is called. */
10140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10142 ffecom_2pass_do_entrypoint (ffesymbol entry)
10144 static int mfn_num = 0;
10145 static int ent_num;
10147 if (mfn_num != ffecom_num_fns_)
10148 { /* First entrypoint for this program unit. */
10150 mfn_num = ffecom_num_fns_;
10151 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10156 --ffecom_num_entrypoints_;
10158 ffecom_do_entry_ (entry, ent_num);
10163 /* Essentially does a "fold (build (code, type, node1, node2))" while
10164 checking for certain housekeeping things. Always sets
10165 TREE_SIDE_EFFECTS. */
10167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10169 ffecom_2s (enum tree_code code, tree type, tree node1,
10174 if ((node1 == error_mark_node)
10175 || (node2 == error_mark_node)
10176 || (type == error_mark_node))
10177 return error_mark_node;
10179 item = build (code, type, node1, node2);
10180 TREE_SIDE_EFFECTS (item) = 1;
10181 return fold (item);
10185 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10186 checking for certain housekeeping things. */
10188 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10190 ffecom_3 (enum tree_code code, tree type, tree node1,
10191 tree node2, tree node3)
10195 if ((node1 == error_mark_node)
10196 || (node2 == error_mark_node)
10197 || (node3 == error_mark_node)
10198 || (type == error_mark_node))
10199 return error_mark_node;
10201 item = build (code, type, node1, node2, node3);
10202 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10203 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10204 TREE_SIDE_EFFECTS (item) = 1;
10205 return fold (item);
10209 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10210 checking for certain housekeeping things. Always sets
10211 TREE_SIDE_EFFECTS. */
10213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10215 ffecom_3s (enum tree_code code, tree type, tree node1,
10216 tree node2, tree node3)
10220 if ((node1 == error_mark_node)
10221 || (node2 == error_mark_node)
10222 || (node3 == error_mark_node)
10223 || (type == error_mark_node))
10224 return error_mark_node;
10226 item = build (code, type, node1, node2, node3);
10227 TREE_SIDE_EFFECTS (item) = 1;
10228 return fold (item);
10233 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10235 See use by ffecom_list_expr.
10237 If expression is NULL, returns an integer zero tree. If it is not
10238 a CHARACTER expression, returns whatever ffecom_expr
10239 returns and sets the length return value to NULL_TREE. Otherwise
10240 generates code to evaluate the character expression, returns the proper
10241 pointer to the result, but does NOT set the length return value to a tree
10242 that specifies the length of the result. (In other words, the length
10243 variable is always set to NULL_TREE, because a length is never passed.)
10246 Don't set returned length, since nobody needs it (yet; someday if
10247 we allow CHARACTER*(*) dummies to statement functions, we'll need
10250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10252 ffecom_arg_expr (ffebld expr, tree *length)
10256 *length = NULL_TREE;
10259 return integer_zero_node;
10261 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10262 return ffecom_expr (expr);
10264 return ffecom_arg_ptr_to_expr (expr, &ign);
10268 /* Transform expression into constant argument-pointer-to-expression tree.
10270 If the expression can be transformed into a argument-pointer-to-expression
10271 tree that is constant, that is done, and the tree returned. Else
10272 NULL_TREE is returned.
10274 That way, a caller can attempt to provide compile-time initialization
10275 of a variable and, if that fails, *then* choose to start a new block
10276 and resort to using temporaries, as appropriate. */
10279 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10282 return integer_zero_node;
10284 if (ffebld_op (expr) == FFEBLD_opANY)
10287 *length = error_mark_node;
10288 return error_mark_node;
10291 if (ffebld_arity (expr) == 0
10292 && (ffebld_op (expr) != FFEBLD_opSYMTER
10293 || ffebld_where (expr) == FFEINFO_whereCOMMON
10294 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10295 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10299 t = ffecom_arg_ptr_to_expr (expr, length);
10300 assert (TREE_CONSTANT (t));
10301 assert (! length || TREE_CONSTANT (*length));
10306 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10307 *length = build_int_2 (ffebld_size (expr), 0);
10309 *length = NULL_TREE;
10313 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10315 See use by ffecom_list_ptr_to_expr.
10317 If expression is NULL, returns an integer zero tree. If it is not
10318 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10319 returns and sets the length return value to NULL_TREE. Otherwise
10320 generates code to evaluate the character expression, returns the proper
10321 pointer to the result, AND sets the length return value to a tree that
10322 specifies the length of the result.
10324 If the length argument is NULL, this is a slightly special
10325 case of building a FORMAT expression, that is, an expression that
10326 will be used at run time without regard to length. For the current
10327 implementation, which uses the libf2c library, this means it is nice
10328 to append a null byte to the end of the expression, where feasible,
10329 to make sure any diagnostic about the FORMAT string terminates at
10332 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10333 length argument. This might even be seen as a feature, if a null
10334 byte can always be appended. */
10336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10338 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10342 ffecomConcatList_ catlist;
10344 if (length != NULL)
10345 *length = NULL_TREE;
10348 return integer_zero_node;
10350 switch (ffebld_op (expr))
10352 case FFEBLD_opPERCENT_VAL:
10353 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10354 return ffecom_expr (ffebld_left (expr));
10359 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10360 if (temp_exp == error_mark_node)
10361 return error_mark_node;
10363 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10367 case FFEBLD_opPERCENT_REF:
10368 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10369 return ffecom_ptr_to_expr (ffebld_left (expr));
10370 if (length != NULL)
10372 ign_length = NULL_TREE;
10373 length = &ign_length;
10375 expr = ffebld_left (expr);
10378 case FFEBLD_opPERCENT_DESCR:
10379 switch (ffeinfo_basictype (ffebld_info (expr)))
10381 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10382 case FFEINFO_basictypeHOLLERITH:
10384 case FFEINFO_basictypeCHARACTER:
10385 break; /* Passed by descriptor anyway. */
10388 item = ffecom_ptr_to_expr (expr);
10389 if (item != error_mark_node)
10390 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10399 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10400 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10401 && (length != NULL))
10402 { /* Pass Hollerith by descriptor. */
10403 ffetargetHollerith h;
10405 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10406 h = ffebld_cu_val_hollerith (ffebld_constant_union
10407 (ffebld_conter (expr)));
10409 = build_int_2 (h.length, 0);
10410 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10414 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10415 return ffecom_ptr_to_expr (expr);
10417 assert (ffeinfo_kindtype (ffebld_info (expr))
10418 == FFEINFO_kindtypeCHARACTER1);
10420 while (ffebld_op (expr) == FFEBLD_opPAREN)
10421 expr = ffebld_left (expr);
10423 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10424 switch (ffecom_concat_list_count_ (catlist))
10426 case 0: /* Shouldn't happen, but in case it does... */
10427 if (length != NULL)
10429 *length = ffecom_f2c_ftnlen_zero_node;
10430 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10432 ffecom_concat_list_kill_ (catlist);
10433 return null_pointer_node;
10435 case 1: /* The (fairly) easy case. */
10436 if (length == NULL)
10437 ffecom_char_args_with_null_ (&item, &ign_length,
10438 ffecom_concat_list_expr_ (catlist, 0));
10440 ffecom_char_args_ (&item, length,
10441 ffecom_concat_list_expr_ (catlist, 0));
10442 ffecom_concat_list_kill_ (catlist);
10443 assert (item != NULL_TREE);
10446 default: /* Must actually concatenate things. */
10451 int count = ffecom_concat_list_count_ (catlist);
10462 ffetargetCharacterSize sz;
10464 sz = ffecom_concat_list_maxlen_ (catlist);
10466 assert (sz != FFETARGET_charactersizeNONE);
10471 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10472 FFETARGET_charactersizeNONE, count, TRUE);
10475 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10476 FFETARGET_charactersizeNONE, count, TRUE);
10477 temporary = ffecom_push_tempvar (char_type_node,
10483 hook = ffebld_nonter_hook (expr);
10485 assert (TREE_CODE (hook) == TREE_VEC);
10486 assert (TREE_VEC_LENGTH (hook) == 3);
10487 length_array = lengths = TREE_VEC_ELT (hook, 0);
10488 item_array = items = TREE_VEC_ELT (hook, 1);
10489 temporary = TREE_VEC_ELT (hook, 2);
10493 known_length = ffecom_f2c_ftnlen_zero_node;
10495 for (i = 0; i < count; ++i)
10498 && (length == NULL))
10499 ffecom_char_args_with_null_ (&citem, &clength,
10500 ffecom_concat_list_expr_ (catlist, i));
10502 ffecom_char_args_ (&citem, &clength,
10503 ffecom_concat_list_expr_ (catlist, i));
10504 if ((citem == error_mark_node)
10505 || (clength == error_mark_node))
10507 ffecom_concat_list_kill_ (catlist);
10508 *length = error_mark_node;
10509 return error_mark_node;
10513 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10514 ffecom_modify (void_type_node,
10515 ffecom_2 (ARRAY_REF,
10516 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10518 build_int_2 (i, 0)),
10521 clength = ffecom_save_tree (clength);
10522 if (length != NULL)
10524 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10528 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10529 ffecom_modify (void_type_node,
10530 ffecom_2 (ARRAY_REF,
10531 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10533 build_int_2 (i, 0)),
10538 temporary = ffecom_1 (ADDR_EXPR,
10539 build_pointer_type (TREE_TYPE (temporary)),
10542 item = build_tree_list (NULL_TREE, temporary);
10544 = build_tree_list (NULL_TREE,
10545 ffecom_1 (ADDR_EXPR,
10546 build_pointer_type (TREE_TYPE (items)),
10548 TREE_CHAIN (TREE_CHAIN (item))
10549 = build_tree_list (NULL_TREE,
10550 ffecom_1 (ADDR_EXPR,
10551 build_pointer_type (TREE_TYPE (lengths)),
10553 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10556 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10557 convert (ffecom_f2c_ftnlen_type_node,
10558 build_int_2 (count, 0))));
10559 num = build_int_2 (sz, 0);
10560 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10561 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10562 = build_tree_list (NULL_TREE, num);
10564 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10565 TREE_SIDE_EFFECTS (item) = 1;
10566 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10570 if (length != NULL)
10571 *length = known_length;
10574 ffecom_concat_list_kill_ (catlist);
10575 assert (item != NULL_TREE);
10580 /* Generate call to run-time function.
10582 The first arg is the GNU Fortran Run-Time function index, the second
10583 arg is the list of arguments to pass to it. Returned is the expression
10584 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10585 result (which may be void). */
10587 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10589 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10591 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10592 ffecom_gfrt_kindtype (ix),
10593 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10594 NULL_TREE, args, NULL_TREE, NULL,
10595 NULL, NULL_TREE, TRUE, hook);
10599 /* Transform constant-union to tree. */
10601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10603 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10604 ffeinfoKindtype kt, tree tree_type)
10610 case FFEINFO_basictypeINTEGER:
10616 #if FFETARGET_okINTEGER1
10617 case FFEINFO_kindtypeINTEGER1:
10618 val = ffebld_cu_val_integer1 (*cu);
10622 #if FFETARGET_okINTEGER2
10623 case FFEINFO_kindtypeINTEGER2:
10624 val = ffebld_cu_val_integer2 (*cu);
10628 #if FFETARGET_okINTEGER3
10629 case FFEINFO_kindtypeINTEGER3:
10630 val = ffebld_cu_val_integer3 (*cu);
10634 #if FFETARGET_okINTEGER4
10635 case FFEINFO_kindtypeINTEGER4:
10636 val = ffebld_cu_val_integer4 (*cu);
10641 assert ("bad INTEGER constant kind type" == NULL);
10642 /* Fall through. */
10643 case FFEINFO_kindtypeANY:
10644 return error_mark_node;
10646 item = build_int_2 (val, (val < 0) ? -1 : 0);
10647 TREE_TYPE (item) = tree_type;
10651 case FFEINFO_basictypeLOGICAL:
10657 #if FFETARGET_okLOGICAL1
10658 case FFEINFO_kindtypeLOGICAL1:
10659 val = ffebld_cu_val_logical1 (*cu);
10663 #if FFETARGET_okLOGICAL2
10664 case FFEINFO_kindtypeLOGICAL2:
10665 val = ffebld_cu_val_logical2 (*cu);
10669 #if FFETARGET_okLOGICAL3
10670 case FFEINFO_kindtypeLOGICAL3:
10671 val = ffebld_cu_val_logical3 (*cu);
10675 #if FFETARGET_okLOGICAL4
10676 case FFEINFO_kindtypeLOGICAL4:
10677 val = ffebld_cu_val_logical4 (*cu);
10682 assert ("bad LOGICAL constant kind type" == NULL);
10683 /* Fall through. */
10684 case FFEINFO_kindtypeANY:
10685 return error_mark_node;
10687 item = build_int_2 (val, (val < 0) ? -1 : 0);
10688 TREE_TYPE (item) = tree_type;
10692 case FFEINFO_basictypeREAL:
10694 REAL_VALUE_TYPE val;
10698 #if FFETARGET_okREAL1
10699 case FFEINFO_kindtypeREAL1:
10700 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10704 #if FFETARGET_okREAL2
10705 case FFEINFO_kindtypeREAL2:
10706 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10710 #if FFETARGET_okREAL3
10711 case FFEINFO_kindtypeREAL3:
10712 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10716 #if FFETARGET_okREAL4
10717 case FFEINFO_kindtypeREAL4:
10718 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10723 assert ("bad REAL constant kind type" == NULL);
10724 /* Fall through. */
10725 case FFEINFO_kindtypeANY:
10726 return error_mark_node;
10728 item = build_real (tree_type, val);
10732 case FFEINFO_basictypeCOMPLEX:
10734 REAL_VALUE_TYPE real;
10735 REAL_VALUE_TYPE imag;
10736 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10740 #if FFETARGET_okCOMPLEX1
10741 case FFEINFO_kindtypeREAL1:
10742 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10743 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10747 #if FFETARGET_okCOMPLEX2
10748 case FFEINFO_kindtypeREAL2:
10749 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10750 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10754 #if FFETARGET_okCOMPLEX3
10755 case FFEINFO_kindtypeREAL3:
10756 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10757 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10761 #if FFETARGET_okCOMPLEX4
10762 case FFEINFO_kindtypeREAL4:
10763 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10764 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10769 assert ("bad REAL constant kind type" == NULL);
10770 /* Fall through. */
10771 case FFEINFO_kindtypeANY:
10772 return error_mark_node;
10774 item = ffecom_build_complex_constant_ (tree_type,
10775 build_real (el_type, real),
10776 build_real (el_type, imag));
10780 case FFEINFO_basictypeCHARACTER:
10781 { /* Happens only in DATA and similar contexts. */
10782 ffetargetCharacter1 val;
10786 #if FFETARGET_okCHARACTER1
10787 case FFEINFO_kindtypeLOGICAL1:
10788 val = ffebld_cu_val_character1 (*cu);
10793 assert ("bad CHARACTER constant kind type" == NULL);
10794 /* Fall through. */
10795 case FFEINFO_kindtypeANY:
10796 return error_mark_node;
10798 item = build_string (ffetarget_length_character1 (val),
10799 ffetarget_text_character1 (val));
10801 = build_type_variant (build_array_type (char_type_node,
10803 (integer_type_node,
10806 (ffetarget_length_character1
10812 case FFEINFO_basictypeHOLLERITH:
10814 ffetargetHollerith h;
10816 h = ffebld_cu_val_hollerith (*cu);
10818 /* If not at least as wide as default INTEGER, widen it. */
10819 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10820 item = build_string (h.length, h.text);
10823 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10825 memcpy (str, h.text, h.length);
10826 memset (&str[h.length], ' ',
10827 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10829 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10833 = build_type_variant (build_array_type (char_type_node,
10835 (integer_type_node,
10843 case FFEINFO_basictypeTYPELESS:
10845 ffetargetInteger1 ival;
10846 ffetargetTypeless tless;
10849 tless = ffebld_cu_val_typeless (*cu);
10850 error = ffetarget_convert_integer1_typeless (&ival, tless);
10851 assert (error == FFEBAD);
10853 item = build_int_2 ((int) ival, 0);
10858 assert ("not yet on constant type" == NULL);
10859 /* Fall through. */
10860 case FFEINFO_basictypeANY:
10861 return error_mark_node;
10864 TREE_CONSTANT (item) = 1;
10871 /* Transform expression into constant tree.
10873 If the expression can be transformed into a tree that is constant,
10874 that is done, and the tree returned. Else NULL_TREE is returned.
10876 That way, a caller can attempt to provide compile-time initialization
10877 of a variable and, if that fails, *then* choose to start a new block
10878 and resort to using temporaries, as appropriate. */
10881 ffecom_const_expr (ffebld expr)
10884 return integer_zero_node;
10886 if (ffebld_op (expr) == FFEBLD_opANY)
10887 return error_mark_node;
10889 if (ffebld_arity (expr) == 0
10890 && (ffebld_op (expr) != FFEBLD_opSYMTER
10892 /* ~~Enable once common/equivalence is handled properly? */
10893 || ffebld_where (expr) == FFEINFO_whereCOMMON
10895 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10896 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10900 t = ffecom_expr (expr);
10901 assert (TREE_CONSTANT (t));
10908 /* Handy way to make a field in a struct/union. */
10910 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10912 ffecom_decl_field (tree context, tree prevfield,
10913 const char *name, tree type)
10917 field = build_decl (FIELD_DECL, get_identifier (name), type);
10918 DECL_CONTEXT (field) = context;
10919 DECL_ALIGN (field) = 0;
10920 DECL_USER_ALIGN (field) = 0;
10921 if (prevfield != NULL_TREE)
10922 TREE_CHAIN (prevfield) = field;
10930 ffecom_close_include (FILE *f)
10932 #if FFECOM_GCC_INCLUDE
10933 ffecom_close_include_ (f);
10938 ffecom_decode_include_option (char *spec)
10940 #if FFECOM_GCC_INCLUDE
10941 return ffecom_decode_include_option_ (spec);
10947 /* End a compound statement (block). */
10949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10951 ffecom_end_compstmt (void)
10953 return bison_rule_compstmt_ ();
10955 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10957 /* ffecom_end_transition -- Perform end transition on all symbols
10959 ffecom_end_transition();
10961 Calls ffecom_sym_end_transition for each global and local symbol. */
10964 ffecom_end_transition ()
10966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10970 if (ffe_is_ffedebug ())
10971 fprintf (dmpout, "; end_stmt_transition\n");
10973 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10974 ffecom_list_blockdata_ = NULL;
10975 ffecom_list_common_ = NULL;
10978 ffesymbol_drive (ffecom_sym_end_transition);
10979 if (ffe_is_ffedebug ())
10981 ffestorag_report ();
10982 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10983 ffesymbol_report_all ();
10987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10988 ffecom_start_progunit_ ();
10990 for (item = ffecom_list_blockdata_;
10992 item = ffebld_trail (item))
10999 static int number = 0;
11001 callee = ffebld_head (item);
11002 s = ffebld_symter (callee);
11003 t = ffesymbol_hook (s).decl_tree;
11004 if (t == NULL_TREE)
11006 s = ffecom_sym_transform_ (s);
11007 t = ffesymbol_hook (s).decl_tree;
11010 dt = build_pointer_type (TREE_TYPE (t));
11012 var = build_decl (VAR_DECL,
11013 ffecom_get_invented_identifier ("__g77_forceload_%d",
11016 DECL_EXTERNAL (var) = 0;
11017 TREE_STATIC (var) = 1;
11018 TREE_PUBLIC (var) = 0;
11019 DECL_INITIAL (var) = error_mark_node;
11020 TREE_USED (var) = 1;
11022 var = start_decl (var, FALSE);
11024 t = ffecom_1 (ADDR_EXPR, dt, t);
11026 finish_decl (var, t, FALSE);
11029 /* This handles any COMMON areas that weren't referenced but have, for
11030 example, important initial data. */
11032 for (item = ffecom_list_common_;
11034 item = ffebld_trail (item))
11035 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11037 ffecom_list_common_ = NULL;
11041 /* ffecom_exec_transition -- Perform exec transition on all symbols
11043 ffecom_exec_transition();
11045 Calls ffecom_sym_exec_transition for each global and local symbol.
11046 Make sure error updating not inhibited. */
11049 ffecom_exec_transition ()
11053 if (ffe_is_ffedebug ())
11054 fprintf (dmpout, "; exec_stmt_transition\n");
11056 inhibited = ffebad_inhibit ();
11057 ffebad_set_inhibit (FALSE);
11059 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11060 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11061 if (ffe_is_ffedebug ())
11063 ffestorag_report ();
11064 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11065 ffesymbol_report_all ();
11070 ffebad_set_inhibit (TRUE);
11073 /* Handle assignment statement.
11075 Convert dest and source using ffecom_expr, then join them
11076 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11078 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11080 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11087 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11092 /* This attempts to replicate the test below, but must not be
11093 true when the test below is false. (Always err on the side
11094 of creating unused temporaries, to avoid ICEs.) */
11095 if (ffebld_op (dest) != FFEBLD_opSYMTER
11096 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11097 && (TREE_CODE (dest_tree) != VAR_DECL
11098 || TREE_ADDRESSABLE (dest_tree))))
11100 ffecom_prepare_expr_ (source, dest);
11105 ffecom_prepare_expr_ (source, NULL);
11109 ffecom_prepare_expr_w (NULL_TREE, dest);
11111 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11112 create a temporary through which the assignment is to take place,
11113 since MODIFY_EXPR doesn't handle partial overlap properly. */
11114 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11115 && ffecom_possible_partial_overlap_ (dest, source))
11117 assign_temp = ffecom_make_tempvar ("complex_let",
11119 [ffebld_basictype (dest)]
11120 [ffebld_kindtype (dest)],
11121 FFETARGET_charactersizeNONE,
11125 assign_temp = NULL_TREE;
11127 ffecom_prepare_end ();
11129 dest_tree = ffecom_expr_w (NULL_TREE, dest);
11130 if (dest_tree == error_mark_node)
11133 if ((TREE_CODE (dest_tree) != VAR_DECL)
11134 || TREE_ADDRESSABLE (dest_tree))
11135 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11139 assert (! dest_used);
11141 source_tree = ffecom_expr (source);
11143 if (source_tree == error_mark_node)
11147 expr_tree = source_tree;
11148 else if (assign_temp)
11151 /* The back end understands a conceptual move (evaluate source;
11152 store into dest), so use that, in case it can determine
11153 that it is going to use, say, two registers as temporaries
11154 anyway. So don't use the temp (and someday avoid generating
11155 it, once this code starts triggering regularly). */
11156 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11160 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11163 expand_expr_stmt (expr_tree);
11164 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11170 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11174 expand_expr_stmt (expr_tree);
11178 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11179 ffecom_prepare_expr_w (NULL_TREE, dest);
11181 ffecom_prepare_end ();
11183 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11184 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11189 /* ffecom_expr -- Transform expr into gcc tree
11192 ffebld expr; // FFE expression.
11193 tree = ffecom_expr(expr);
11195 Recursive descent on expr while making corresponding tree nodes and
11196 attaching type info and such. */
11198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11200 ffecom_expr (ffebld expr)
11202 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11206 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11208 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11210 ffecom_expr_assign (ffebld expr)
11212 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11216 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11220 ffecom_expr_assign_w (ffebld expr)
11222 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11226 /* Transform expr for use as into read/write tree and stabilize the
11227 reference. Not for use on CHARACTER expressions.
11229 Recursive descent on expr while making corresponding tree nodes and
11230 attaching type info and such. */
11232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11234 ffecom_expr_rw (tree type, ffebld expr)
11236 assert (expr != NULL);
11237 /* Different target types not yet supported. */
11238 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11240 return stabilize_reference (ffecom_expr (expr));
11244 /* Transform expr for use as into write tree and stabilize the
11245 reference. Not for use on CHARACTER expressions.
11247 Recursive descent on expr while making corresponding tree nodes and
11248 attaching type info and such. */
11250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11252 ffecom_expr_w (tree type, ffebld expr)
11254 assert (expr != NULL);
11255 /* Different target types not yet supported. */
11256 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11258 return stabilize_reference (ffecom_expr (expr));
11262 /* Do global stuff. */
11264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11266 ffecom_finish_compile ()
11268 assert (ffecom_outer_function_decl_ == NULL_TREE);
11269 assert (current_function_decl == NULL_TREE);
11271 ffeglobal_drive (ffecom_finish_global_);
11275 /* Public entry point for front end to access finish_decl. */
11277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11279 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11281 assert (!is_top_level);
11282 finish_decl (decl, init, FALSE);
11286 /* Finish a program unit. */
11288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11290 ffecom_finish_progunit ()
11292 ffecom_end_compstmt ();
11294 ffecom_previous_function_decl_ = current_function_decl;
11295 ffecom_which_entrypoint_decl_ = NULL_TREE;
11297 finish_function (0);
11302 /* Wrapper for get_identifier. pattern is sprintf-like. */
11304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11306 ffecom_get_invented_identifier (const char *pattern, ...)
11312 va_start (ap, pattern);
11313 if (vasprintf (&nam, pattern, ap) == 0)
11316 decl = get_identifier (nam);
11318 IDENTIFIER_INVENTED (decl) = 1;
11323 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11325 assert (gfrt < FFECOM_gfrt);
11327 switch (ffecom_gfrt_type_[gfrt])
11329 case FFECOM_rttypeVOID_:
11330 case FFECOM_rttypeVOIDSTAR_:
11331 return FFEINFO_basictypeNONE;
11333 case FFECOM_rttypeFTNINT_:
11334 return FFEINFO_basictypeINTEGER;
11336 case FFECOM_rttypeINTEGER_:
11337 return FFEINFO_basictypeINTEGER;
11339 case FFECOM_rttypeLONGINT_:
11340 return FFEINFO_basictypeINTEGER;
11342 case FFECOM_rttypeLOGICAL_:
11343 return FFEINFO_basictypeLOGICAL;
11345 case FFECOM_rttypeREAL_F2C_:
11346 case FFECOM_rttypeREAL_GNU_:
11347 return FFEINFO_basictypeREAL;
11349 case FFECOM_rttypeCOMPLEX_F2C_:
11350 case FFECOM_rttypeCOMPLEX_GNU_:
11351 return FFEINFO_basictypeCOMPLEX;
11353 case FFECOM_rttypeDOUBLE_:
11354 case FFECOM_rttypeDOUBLEREAL_:
11355 return FFEINFO_basictypeREAL;
11357 case FFECOM_rttypeDBLCMPLX_F2C_:
11358 case FFECOM_rttypeDBLCMPLX_GNU_:
11359 return FFEINFO_basictypeCOMPLEX;
11361 case FFECOM_rttypeCHARACTER_:
11362 return FFEINFO_basictypeCHARACTER;
11365 return FFEINFO_basictypeANY;
11370 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11372 assert (gfrt < FFECOM_gfrt);
11374 switch (ffecom_gfrt_type_[gfrt])
11376 case FFECOM_rttypeVOID_:
11377 case FFECOM_rttypeVOIDSTAR_:
11378 return FFEINFO_kindtypeNONE;
11380 case FFECOM_rttypeFTNINT_:
11381 return FFEINFO_kindtypeINTEGER1;
11383 case FFECOM_rttypeINTEGER_:
11384 return FFEINFO_kindtypeINTEGER1;
11386 case FFECOM_rttypeLONGINT_:
11387 return FFEINFO_kindtypeINTEGER4;
11389 case FFECOM_rttypeLOGICAL_:
11390 return FFEINFO_kindtypeLOGICAL1;
11392 case FFECOM_rttypeREAL_F2C_:
11393 case FFECOM_rttypeREAL_GNU_:
11394 return FFEINFO_kindtypeREAL1;
11396 case FFECOM_rttypeCOMPLEX_F2C_:
11397 case FFECOM_rttypeCOMPLEX_GNU_:
11398 return FFEINFO_kindtypeREAL1;
11400 case FFECOM_rttypeDOUBLE_:
11401 case FFECOM_rttypeDOUBLEREAL_:
11402 return FFEINFO_kindtypeREAL2;
11404 case FFECOM_rttypeDBLCMPLX_F2C_:
11405 case FFECOM_rttypeDBLCMPLX_GNU_:
11406 return FFEINFO_kindtypeREAL2;
11408 case FFECOM_rttypeCHARACTER_:
11409 return FFEINFO_kindtypeCHARACTER1;
11412 return FFEINFO_kindtypeANY;
11426 tree double_ftype_double;
11427 tree float_ftype_float;
11428 tree ldouble_ftype_ldouble;
11429 tree ffecom_tree_ptr_to_fun_type_void;
11431 /* This block of code comes from the now-obsolete cktyps.c. It checks
11432 whether the compiler environment is buggy in known ways, some of which
11433 would, if not explicitly checked here, result in subtle bugs in g77. */
11435 if (ffe_is_do_internal_checks ())
11437 static char names[][12]
11439 {"bar", "bletch", "foo", "foobar"};
11444 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11445 (int (*)(const void *, const void *)) strcmp);
11446 if (name != (char *) &names[2])
11448 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11453 ul = strtoul ("123456789", NULL, 10);
11454 if (ul != 123456789L)
11456 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11457 in proj.h" == NULL);
11461 fl = atof ("56.789");
11462 if ((fl < 56.788) || (fl > 56.79))
11464 assert ("atof not type double, fix your #include <stdio.h>"
11470 #if FFECOM_GCC_INCLUDE
11471 ffecom_initialize_char_syntax_ ();
11474 ffecom_outer_function_decl_ = NULL_TREE;
11475 current_function_decl = NULL_TREE;
11476 named_labels = NULL_TREE;
11477 current_binding_level = NULL_BINDING_LEVEL;
11478 free_binding_level = NULL_BINDING_LEVEL;
11479 /* Make the binding_level structure for global names. */
11481 global_binding_level = current_binding_level;
11482 current_binding_level->prep_state = 2;
11484 build_common_tree_nodes (1);
11486 /* Define `int' and `char' first so that dbx will output them first. */
11487 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11488 integer_type_node));
11489 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11491 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11492 long_integer_type_node));
11493 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11494 unsigned_type_node));
11495 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11496 long_unsigned_type_node));
11497 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11498 long_long_integer_type_node));
11499 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11500 long_long_unsigned_type_node));
11501 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11502 short_integer_type_node));
11503 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11504 short_unsigned_type_node));
11506 /* Set the sizetype before we make other types. This *should* be the
11507 first type we create. */
11510 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11511 ffecom_typesize_pointer_
11512 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11514 build_common_tree_nodes_2 (0);
11516 /* Define both `signed char' and `unsigned char'. */
11517 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11518 signed_char_type_node));
11520 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11521 unsigned_char_type_node));
11523 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11525 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11526 double_type_node));
11527 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11528 long_double_type_node));
11530 /* For now, override what build_common_tree_nodes has done. */
11531 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11532 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11533 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11534 complex_long_double_type_node
11535 = ffecom_make_complex_type_ (long_double_type_node);
11537 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11538 complex_integer_type_node));
11539 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11540 complex_float_type_node));
11541 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11542 complex_double_type_node));
11543 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11544 complex_long_double_type_node));
11546 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11548 /* We are not going to have real types in C with less than byte alignment,
11549 so we might as well not have any types that claim to have it. */
11550 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11551 TYPE_USER_ALIGN (void_type_node) = 0;
11553 string_type_node = build_pointer_type (char_type_node);
11555 ffecom_tree_fun_type_void
11556 = build_function_type (void_type_node, NULL_TREE);
11558 ffecom_tree_ptr_to_fun_type_void
11559 = build_pointer_type (ffecom_tree_fun_type_void);
11561 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11564 = build_function_type (float_type_node,
11565 tree_cons (NULL_TREE, float_type_node, endlink));
11567 double_ftype_double
11568 = build_function_type (double_type_node,
11569 tree_cons (NULL_TREE, double_type_node, endlink));
11571 ldouble_ftype_ldouble
11572 = build_function_type (long_double_type_node,
11573 tree_cons (NULL_TREE, long_double_type_node,
11576 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11577 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11579 ffecom_tree_type[i][j] = NULL_TREE;
11580 ffecom_tree_fun_type[i][j] = NULL_TREE;
11581 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11582 ffecom_f2c_typecode_[i][j] = -1;
11585 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11586 to size FLOAT_TYPE_SIZE because they have to be the same size as
11587 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11588 Compiler options and other such stuff that change the ways these
11589 types are set should not affect this particular setup. */
11591 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11592 = t = make_signed_type (FLOAT_TYPE_SIZE);
11593 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11595 type = ffetype_new ();
11597 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11599 ffetype_set_ams (type,
11600 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11601 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11602 ffetype_set_star (base_type,
11603 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11605 ffetype_set_kind (base_type, 1, type);
11606 ffecom_typesize_integer1_ = ffetype_size (type);
11607 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11609 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11610 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11611 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11614 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11615 = t = make_signed_type (CHAR_TYPE_SIZE);
11616 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11618 type = ffetype_new ();
11619 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11621 ffetype_set_ams (type,
11622 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11623 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11624 ffetype_set_star (base_type,
11625 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11627 ffetype_set_kind (base_type, 3, type);
11628 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11630 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11631 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11632 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11635 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11636 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11637 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11639 type = ffetype_new ();
11640 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11642 ffetype_set_ams (type,
11643 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11644 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11645 ffetype_set_star (base_type,
11646 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11648 ffetype_set_kind (base_type, 6, type);
11649 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11651 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11652 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11653 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11656 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11657 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11658 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11660 type = ffetype_new ();
11661 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11663 ffetype_set_ams (type,
11664 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11665 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11666 ffetype_set_star (base_type,
11667 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11669 ffetype_set_kind (base_type, 2, type);
11670 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11672 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11673 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11674 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11678 if (ffe_is_do_internal_checks ()
11679 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11680 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11681 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11682 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11684 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11689 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11690 = t = make_signed_type (FLOAT_TYPE_SIZE);
11691 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11693 type = ffetype_new ();
11695 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11697 ffetype_set_ams (type,
11698 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11699 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11700 ffetype_set_star (base_type,
11701 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11703 ffetype_set_kind (base_type, 1, type);
11704 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11706 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11707 = t = make_signed_type (CHAR_TYPE_SIZE);
11708 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11710 type = ffetype_new ();
11711 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
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 (ffetargetLogical2));
11722 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11723 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11724 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11726 type = ffetype_new ();
11727 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11729 ffetype_set_ams (type,
11730 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11731 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11732 ffetype_set_star (base_type,
11733 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11735 ffetype_set_kind (base_type, 6, type);
11736 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11738 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11739 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11740 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11742 type = ffetype_new ();
11743 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11745 ffetype_set_ams (type,
11746 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11747 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11748 ffetype_set_star (base_type,
11749 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11751 ffetype_set_kind (base_type, 2, type);
11752 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11754 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11755 = t = make_node (REAL_TYPE);
11756 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11757 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11760 type = ffetype_new ();
11762 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11764 ffetype_set_ams (type,
11765 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11766 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11767 ffetype_set_star (base_type,
11768 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11770 ffetype_set_kind (base_type, 1, type);
11771 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11772 = FFETARGET_f2cTYREAL;
11773 assert (ffetype_size (type) == sizeof (ffetargetReal1));
11775 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11776 = t = make_node (REAL_TYPE);
11777 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11778 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11781 type = ffetype_new ();
11782 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11784 ffetype_set_ams (type,
11785 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11786 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11787 ffetype_set_star (base_type,
11788 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11790 ffetype_set_kind (base_type, 2, type);
11791 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11792 = FFETARGET_f2cTYDREAL;
11793 assert (ffetype_size (type) == sizeof (ffetargetReal2));
11795 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11796 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11797 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11799 type = ffetype_new ();
11801 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11803 ffetype_set_ams (type,
11804 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11805 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11806 ffetype_set_star (base_type,
11807 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11809 ffetype_set_kind (base_type, 1, type);
11810 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11811 = FFETARGET_f2cTYCOMPLEX;
11812 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11814 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11815 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11816 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11818 type = ffetype_new ();
11819 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
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, 2,
11829 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11830 = FFETARGET_f2cTYDCOMPLEX;
11831 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11833 /* Make function and ptr-to-function types for non-CHARACTER types. */
11835 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11836 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11838 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11840 if (i == FFEINFO_basictypeINTEGER)
11842 /* Figure out the smallest INTEGER type that can hold
11843 a pointer on this machine. */
11844 if (GET_MODE_SIZE (TYPE_MODE (t))
11845 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11847 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11848 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11849 > GET_MODE_SIZE (TYPE_MODE (t))))
11850 ffecom_pointer_kind_ = j;
11853 else if (i == FFEINFO_basictypeCOMPLEX)
11854 t = void_type_node;
11855 /* For f2c compatibility, REAL functions are really
11856 implemented as DOUBLE PRECISION. */
11857 else if ((i == FFEINFO_basictypeREAL)
11858 && (j == FFEINFO_kindtypeREAL1))
11859 t = ffecom_tree_type
11860 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11862 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11864 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11868 /* Set up pointer types. */
11870 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11871 fatal ("no INTEGER type can hold a pointer on this configuration");
11872 else if (0 && ffe_is_do_internal_checks ())
11873 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11874 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11875 FFEINFO_kindtypeINTEGERDEFAULT),
11877 ffeinfo_type (FFEINFO_basictypeINTEGER,
11878 ffecom_pointer_kind_));
11880 if (ffe_is_ugly_assign ())
11881 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
11883 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11884 if (0 && ffe_is_do_internal_checks ())
11885 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11887 ffecom_integer_type_node
11888 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11889 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11890 integer_zero_node);
11891 ffecom_integer_one_node = convert (ffecom_integer_type_node,
11894 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11895 Turns out that by TYLONG, runtime/libI77/lio.h really means
11896 "whatever size an ftnint is". For consistency and sanity,
11897 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11898 all are INTEGER, which we also make out of whatever back-end
11899 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11900 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11901 accommodate machines like the Alpha. Note that this suggests
11902 f2c and libf2c are missing a distinction perhaps needed on
11903 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11905 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11906 FFETARGET_f2cTYLONG);
11907 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11908 FFETARGET_f2cTYSHORT);
11909 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11910 FFETARGET_f2cTYINT1);
11911 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11912 FFETARGET_f2cTYQUAD);
11913 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11914 FFETARGET_f2cTYLOGICAL);
11915 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11916 FFETARGET_f2cTYLOGICAL2);
11917 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11918 FFETARGET_f2cTYLOGICAL1);
11919 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11920 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11921 FFETARGET_f2cTYQUAD);
11923 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11924 loop. CHARACTER items are built as arrays of unsigned char. */
11926 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11927 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11928 type = ffetype_new ();
11930 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11931 FFEINFO_kindtypeCHARACTER1,
11933 ffetype_set_ams (type,
11934 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11935 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11936 ffetype_set_kind (base_type, 1, type);
11937 assert (ffetype_size (type)
11938 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11940 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11941 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11942 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11943 [FFEINFO_kindtypeCHARACTER1]
11944 = ffecom_tree_ptr_to_fun_type_void;
11945 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11946 = FFETARGET_f2cTYCHAR;
11948 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11951 /* Make multi-return-value type and fields. */
11953 ffecom_multi_type_node_ = make_node (UNION_TYPE);
11957 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11958 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11962 if (ffecom_tree_type[i][j] == NULL_TREE)
11963 continue; /* Not supported. */
11964 sprintf (&name[0], "bt_%s_kt_%s",
11965 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11966 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11967 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11968 get_identifier (name),
11969 ffecom_tree_type[i][j]);
11970 DECL_CONTEXT (ffecom_multi_fields_[i][j])
11971 = ffecom_multi_type_node_;
11972 DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11973 DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11974 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11975 field = ffecom_multi_fields_[i][j];
11978 TYPE_FIELDS (ffecom_multi_type_node_) = field;
11979 layout_type (ffecom_multi_type_node_);
11981 /* Subroutines usually return integer because they might have alternate
11984 ffecom_tree_subr_type
11985 = build_function_type (integer_type_node, NULL_TREE);
11986 ffecom_tree_ptr_to_subr_type
11987 = build_pointer_type (ffecom_tree_subr_type);
11988 ffecom_tree_blockdata_type
11989 = build_function_type (void_type_node, NULL_TREE);
11991 builtin_function ("__builtin_sqrtf", float_ftype_float,
11992 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11993 builtin_function ("__builtin_fsqrt", double_ftype_double,
11994 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11995 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11996 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11997 builtin_function ("__builtin_sinf", float_ftype_float,
11998 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11999 builtin_function ("__builtin_sin", double_ftype_double,
12000 BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12001 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12002 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12003 builtin_function ("__builtin_cosf", float_ftype_float,
12004 BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12005 builtin_function ("__builtin_cos", double_ftype_double,
12006 BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12007 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12008 BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12011 pedantic_lvalues = FALSE;
12014 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12017 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12020 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12023 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12024 FFECOM_f2cDOUBLEREAL,
12026 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12029 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12030 FFECOM_f2cDOUBLECOMPLEX,
12032 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12035 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12038 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12041 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12044 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12048 ffecom_f2c_ftnlen_zero_node
12049 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12051 ffecom_f2c_ftnlen_one_node
12052 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12054 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12055 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12057 ffecom_f2c_ptr_to_ftnlen_type_node
12058 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12060 ffecom_f2c_ptr_to_ftnint_type_node
12061 = build_pointer_type (ffecom_f2c_ftnint_type_node);
12063 ffecom_f2c_ptr_to_integer_type_node
12064 = build_pointer_type (ffecom_f2c_integer_type_node);
12066 ffecom_f2c_ptr_to_real_type_node
12067 = build_pointer_type (ffecom_f2c_real_type_node);
12069 ffecom_float_zero_ = build_real (float_type_node, dconst0);
12070 ffecom_double_zero_ = build_real (double_type_node, dconst0);
12072 REAL_VALUE_TYPE point_5;
12074 #ifdef REAL_ARITHMETIC
12075 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12079 ffecom_float_half_ = build_real (float_type_node, point_5);
12080 ffecom_double_half_ = build_real (double_type_node, point_5);
12083 /* Do "extern int xargc;". */
12085 ffecom_tree_xargc_ = build_decl (VAR_DECL,
12086 get_identifier ("f__xargc"),
12087 integer_type_node);
12088 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12089 TREE_STATIC (ffecom_tree_xargc_) = 1;
12090 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12091 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12092 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12094 #if 0 /* This is being fixed, and seems to be working now. */
12095 if ((FLOAT_TYPE_SIZE != 32)
12096 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12098 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12099 (int) FLOAT_TYPE_SIZE);
12100 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12101 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12102 warning ("properly unless they all are 32 bits wide.");
12103 warning ("Please keep this in mind before you report bugs. g77 should");
12104 warning ("support non-32-bit machines better as of version 0.6.");
12108 #if 0 /* Code in ste.c that would crash has been commented out. */
12109 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12110 < TYPE_PRECISION (string_type_node))
12111 /* I/O will probably crash. */
12112 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12113 TYPE_PRECISION (string_type_node),
12114 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12117 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12118 if (TYPE_PRECISION (ffecom_integer_type_node)
12119 < TYPE_PRECISION (string_type_node))
12120 /* ASSIGN 10 TO I will crash. */
12121 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12122 ASSIGN statement might fail",
12123 TYPE_PRECISION (string_type_node),
12124 TYPE_PRECISION (ffecom_integer_type_node));
12129 /* ffecom_init_2 -- Initialize
12131 ffecom_init_2(); */
12133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12137 assert (ffecom_outer_function_decl_ == NULL_TREE);
12138 assert (current_function_decl == NULL_TREE);
12139 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12141 ffecom_master_arglist_ = NULL;
12143 ffecom_primary_entry_ = NULL;
12144 ffecom_is_altreturning_ = FALSE;
12145 ffecom_func_result_ = NULL_TREE;
12146 ffecom_multi_retval_ = NULL_TREE;
12150 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12153 ffebld expr; // FFE opITEM list.
12154 tree = ffecom_list_expr(expr);
12156 List of actual args is transformed into corresponding gcc backend list. */
12158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12160 ffecom_list_expr (ffebld expr)
12163 tree *plist = &list;
12164 tree trail = NULL_TREE; /* Append char length args here. */
12165 tree *ptrail = &trail;
12168 while (expr != NULL)
12170 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12172 if (texpr == error_mark_node)
12173 return error_mark_node;
12175 *plist = build_tree_list (NULL_TREE, texpr);
12176 plist = &TREE_CHAIN (*plist);
12177 expr = ffebld_trail (expr);
12178 if (length != NULL_TREE)
12180 *ptrail = build_tree_list (NULL_TREE, length);
12181 ptrail = &TREE_CHAIN (*ptrail);
12191 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12194 ffebld expr; // FFE opITEM list.
12195 tree = ffecom_list_ptr_to_expr(expr);
12197 List of actual args is transformed into corresponding gcc backend list for
12198 use in calling an external procedure (vs. a statement function). */
12200 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12202 ffecom_list_ptr_to_expr (ffebld expr)
12205 tree *plist = &list;
12206 tree trail = NULL_TREE; /* Append char length args here. */
12207 tree *ptrail = &trail;
12210 while (expr != NULL)
12212 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12214 if (texpr == error_mark_node)
12215 return error_mark_node;
12217 *plist = build_tree_list (NULL_TREE, texpr);
12218 plist = &TREE_CHAIN (*plist);
12219 expr = ffebld_trail (expr);
12220 if (length != NULL_TREE)
12222 *ptrail = build_tree_list (NULL_TREE, length);
12223 ptrail = &TREE_CHAIN (*ptrail);
12233 /* Obtain gcc's LABEL_DECL tree for label. */
12235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12237 ffecom_lookup_label (ffelab label)
12241 if (ffelab_hook (label) == NULL_TREE)
12243 char labelname[16];
12245 switch (ffelab_type (label))
12247 case FFELAB_typeLOOPEND:
12248 case FFELAB_typeNOTLOOP:
12249 case FFELAB_typeENDIF:
12250 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12251 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12253 DECL_CONTEXT (glabel) = current_function_decl;
12254 DECL_MODE (glabel) = VOIDmode;
12257 case FFELAB_typeFORMAT:
12258 glabel = build_decl (VAR_DECL,
12259 ffecom_get_invented_identifier
12260 ("__g77_format_%d", (int) ffelab_value (label)),
12261 build_type_variant (build_array_type
12265 TREE_CONSTANT (glabel) = 1;
12266 TREE_STATIC (glabel) = 1;
12267 DECL_CONTEXT (glabel) = current_function_decl;
12268 DECL_INITIAL (glabel) = NULL;
12269 make_decl_rtl (glabel, NULL);
12270 expand_decl (glabel);
12272 ffecom_save_tree_forever (glabel);
12276 case FFELAB_typeANY:
12277 glabel = error_mark_node;
12281 assert ("bad label type" == NULL);
12285 ffelab_set_hook (label, glabel);
12289 glabel = ffelab_hook (label);
12296 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12297 a single source specification (as in the fourth argument of MVBITS).
12298 If the type is NULL_TREE, the type of lhs is used to make the type of
12299 the MODIFY_EXPR. */
12301 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12303 ffecom_modify (tree newtype, tree lhs,
12306 if (lhs == error_mark_node || rhs == error_mark_node)
12307 return error_mark_node;
12309 if (newtype == NULL_TREE)
12310 newtype = TREE_TYPE (lhs);
12312 if (TREE_SIDE_EFFECTS (lhs))
12313 lhs = stabilize_reference (lhs);
12315 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12320 /* Register source file name. */
12323 ffecom_file (const char *name)
12325 #if FFECOM_GCC_INCLUDE
12326 ffecom_file_ (name);
12330 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12333 ffecom_notify_init_storage(st);
12335 Gets called when all possible units in an aggregate storage area (a LOCAL
12336 with equivalences or a COMMON) have been initialized. The initialization
12337 info either is in ffestorag_init or, if that is NULL,
12338 ffestorag_accretion:
12340 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12341 even for an array if the array is one element in length!
12343 ffestorag_accretion will contain an opACCTER. It is much like an
12344 opARRTER except it has an ffebit object in it instead of just a size.
12345 The back end can use the info in the ffebit object, if it wants, to
12346 reduce the amount of actual initialization, but in any case it should
12347 kill the ffebit object when done. Also, set accretion to NULL but
12348 init to a non-NULL value.
12350 After performing initialization, DO NOT set init to NULL, because that'll
12351 tell the front end it is ok for more initialization to happen. Instead,
12352 set init to an opANY expression or some such thing that you can use to
12353 tell that you've already initialized the object.
12356 Support two-pass FFE. */
12359 ffecom_notify_init_storage (ffestorag st)
12361 ffebld init; /* The initialization expression. */
12362 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12363 ffetargetOffset size; /* The size of the entity. */
12364 ffetargetAlign pad; /* Its initial padding. */
12367 if (ffestorag_init (st) == NULL)
12369 init = ffestorag_accretion (st);
12370 assert (init != NULL);
12371 ffestorag_set_accretion (st, NULL);
12372 ffestorag_set_accretes (st, 0);
12374 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12375 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12376 size = ffebld_accter_size (init);
12377 pad = ffebld_accter_pad (init);
12378 ffebit_kill (ffebld_accter_bits (init));
12379 ffebld_set_op (init, FFEBLD_opARRTER);
12380 ffebld_set_arrter (init, ffebld_accter (init));
12381 ffebld_arrter_set_size (init, size);
12382 ffebld_arrter_set_pad (init, size);
12386 ffestorag_set_init (st, init);
12391 init = ffestorag_init (st);
12394 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12395 ffestorag_set_init (st, ffebld_new_any ());
12397 if (ffebld_op (init) == FFEBLD_opANY)
12398 return; /* Oh, we already did this! */
12400 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12404 if (ffestorag_symbol (st) != NULL)
12405 s = ffestorag_symbol (st);
12407 s = ffestorag_typesymbol (st);
12409 fprintf (dmpout, "= initialize_storage \"%s\" ",
12410 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12411 ffebld_dump (init);
12412 fputc ('\n', dmpout);
12416 #endif /* if FFECOM_ONEPASS */
12419 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12422 ffecom_notify_init_symbol(s);
12424 Gets called when all possible units in a symbol (not placed in COMMON
12425 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12426 have been initialized. The initialization info either is in
12427 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12429 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12430 even for an array if the array is one element in length!
12432 ffesymbol_accretion will contain an opACCTER. It is much like an
12433 opARRTER except it has an ffebit object in it instead of just a size.
12434 The back end can use the info in the ffebit object, if it wants, to
12435 reduce the amount of actual initialization, but in any case it should
12436 kill the ffebit object when done. Also, set accretion to NULL but
12437 init to a non-NULL value.
12439 After performing initialization, DO NOT set init to NULL, because that'll
12440 tell the front end it is ok for more initialization to happen. Instead,
12441 set init to an opANY expression or some such thing that you can use to
12442 tell that you've already initialized the object.
12445 Support two-pass FFE. */
12448 ffecom_notify_init_symbol (ffesymbol s)
12450 ffebld init; /* The initialization expression. */
12451 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12452 ffetargetOffset size; /* The size of the entity. */
12453 ffetargetAlign pad; /* Its initial padding. */
12456 if (ffesymbol_storage (s) == NULL)
12457 return; /* Do nothing until COMMON/EQUIVALENCE
12458 possibilities checked. */
12460 if ((ffesymbol_init (s) == NULL)
12461 && ((init = ffesymbol_accretion (s)) != NULL))
12463 ffesymbol_set_accretion (s, NULL);
12464 ffesymbol_set_accretes (s, 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 ffesymbol_set_init (s, init);
12483 init = ffesymbol_init (s);
12487 ffesymbol_set_init (s, ffebld_new_any ());
12489 if (ffebld_op (init) == FFEBLD_opANY)
12490 return; /* Oh, we already did this! */
12492 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12493 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12494 ffebld_dump (init);
12495 fputc ('\n', dmpout);
12498 #endif /* if FFECOM_ONEPASS */
12501 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12504 ffecom_notify_primary_entry(s);
12506 Gets called when implicit or explicit PROGRAM statement seen or when
12507 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12508 global symbol that serves as the entry point. */
12511 ffecom_notify_primary_entry (ffesymbol s)
12513 ffecom_primary_entry_ = s;
12514 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12516 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12517 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12518 ffecom_primary_entry_is_proc_ = TRUE;
12520 ffecom_primary_entry_is_proc_ = FALSE;
12522 if (!ffe_is_silent ())
12524 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12525 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12527 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12530 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12531 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12536 for (list = ffesymbol_dummyargs (s);
12538 list = ffebld_trail (list))
12540 arg = ffebld_head (list);
12541 if (ffebld_op (arg) == FFEBLD_opSTAR)
12543 ffecom_is_altreturning_ = TRUE;
12552 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12554 #if FFECOM_GCC_INCLUDE
12555 return ffecom_open_include_ (name, l, c);
12557 return fopen (name, "r");
12561 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12564 ffebld expr; // FFE expression.
12565 tree = ffecom_ptr_to_expr(expr);
12567 Like ffecom_expr, but sticks address-of in front of most things. */
12569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12571 ffecom_ptr_to_expr (ffebld expr)
12574 ffeinfoBasictype bt;
12575 ffeinfoKindtype kt;
12578 assert (expr != NULL);
12580 switch (ffebld_op (expr))
12582 case FFEBLD_opSYMTER:
12583 s = ffebld_symter (expr);
12584 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12588 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12589 assert (ix != FFECOM_gfrt);
12590 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12592 ffecom_make_gfrt_ (ix);
12593 item = ffecom_gfrt_[ix];
12598 item = ffesymbol_hook (s).decl_tree;
12599 if (item == NULL_TREE)
12601 s = ffecom_sym_transform_ (s);
12602 item = ffesymbol_hook (s).decl_tree;
12605 assert (item != NULL);
12606 if (item == error_mark_node)
12608 if (!ffesymbol_hook (s).addr)
12609 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12613 case FFEBLD_opARRAYREF:
12614 return ffecom_arrayref_ (NULL_TREE, expr, 1);
12616 case FFEBLD_opCONTER:
12618 bt = ffeinfo_basictype (ffebld_info (expr));
12619 kt = ffeinfo_kindtype (ffebld_info (expr));
12621 item = ffecom_constantunion (&ffebld_constant_union
12622 (ffebld_conter (expr)), bt, kt,
12623 ffecom_tree_type[bt][kt]);
12624 if (item == error_mark_node)
12625 return error_mark_node;
12626 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12631 return error_mark_node;
12634 bt = ffeinfo_basictype (ffebld_info (expr));
12635 kt = ffeinfo_kindtype (ffebld_info (expr));
12637 item = ffecom_expr (expr);
12638 if (item == error_mark_node)
12639 return error_mark_node;
12641 /* The back end currently optimizes a bit too zealously for us, in that
12642 we fail JCB001 if the following block of code is omitted. It checks
12643 to see if the transformed expression is a symbol or array reference,
12644 and encloses it in a SAVE_EXPR if that is the case. */
12647 if ((TREE_CODE (item) == VAR_DECL)
12648 || (TREE_CODE (item) == PARM_DECL)
12649 || (TREE_CODE (item) == RESULT_DECL)
12650 || (TREE_CODE (item) == INDIRECT_REF)
12651 || (TREE_CODE (item) == ARRAY_REF)
12652 || (TREE_CODE (item) == COMPONENT_REF)
12654 || (TREE_CODE (item) == OFFSET_REF)
12656 || (TREE_CODE (item) == BUFFER_REF)
12657 || (TREE_CODE (item) == REALPART_EXPR)
12658 || (TREE_CODE (item) == IMAGPART_EXPR))
12660 item = ffecom_save_tree (item);
12663 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12668 assert ("fall-through error" == NULL);
12669 return error_mark_node;
12673 /* Obtain a temp var with given data type.
12675 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12676 or >= 0 for a CHARACTER type.
12678 elements is -1 for a scalar or > 0 for an array of type. */
12680 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12682 ffecom_make_tempvar (const char *commentary, tree type,
12683 ffetargetCharacterSize size, int elements)
12686 static int mynumber;
12688 assert (current_binding_level->prep_state < 2);
12690 if (type == error_mark_node)
12691 return error_mark_node;
12693 if (size != FFETARGET_charactersizeNONE)
12694 type = build_array_type (type,
12695 build_range_type (ffecom_f2c_ftnlen_type_node,
12696 ffecom_f2c_ftnlen_one_node,
12697 build_int_2 (size, 0)));
12698 if (elements != -1)
12699 type = build_array_type (type,
12700 build_range_type (integer_type_node,
12702 build_int_2 (elements - 1,
12704 t = build_decl (VAR_DECL,
12705 ffecom_get_invented_identifier ("__g77_%s_%d",
12710 t = start_decl (t, FALSE);
12711 finish_decl (t, NULL_TREE, FALSE);
12717 /* Prepare argument pointer to expression.
12719 Like ffecom_prepare_expr, except for expressions to be evaluated
12720 via ffecom_arg_ptr_to_expr. */
12723 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12725 /* ~~For now, it seems to be the same thing. */
12726 ffecom_prepare_expr (expr);
12730 /* End of preparations. */
12733 ffecom_prepare_end (void)
12735 int prep_state = current_binding_level->prep_state;
12737 assert (prep_state < 2);
12738 current_binding_level->prep_state = 2;
12740 return (prep_state == 1) ? TRUE : FALSE;
12743 /* Prepare expression.
12745 This is called before any code is generated for the current block.
12746 It scans the expression, declares any temporaries that might be needed
12747 during evaluation of the expression, and stores those temporaries in
12748 the appropriate "hook" fields of the expression. `dest', if not NULL,
12749 specifies the destination that ffecom_expr_ will see, in case that
12750 helps avoid generating unused temporaries.
12752 ~~Improve to avoid allocating unused temporaries by taking `dest'
12753 into account vis-a-vis aliasing requirements of complex/character
12757 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12759 ffeinfoBasictype bt;
12760 ffeinfoKindtype kt;
12761 ffetargetCharacterSize sz;
12762 tree tempvar = NULL_TREE;
12764 assert (current_binding_level->prep_state < 2);
12769 bt = ffeinfo_basictype (ffebld_info (expr));
12770 kt = ffeinfo_kindtype (ffebld_info (expr));
12771 sz = ffeinfo_size (ffebld_info (expr));
12773 /* Generate whatever temporaries are needed to represent the result
12774 of the expression. */
12776 if (bt == FFEINFO_basictypeCHARACTER)
12778 while (ffebld_op (expr) == FFEBLD_opPAREN)
12779 expr = ffebld_left (expr);
12782 switch (ffebld_op (expr))
12785 /* Don't make temps for SYMTER, CONTER, etc. */
12786 if (ffebld_arity (expr) == 0)
12791 case FFEINFO_basictypeCOMPLEX:
12792 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12796 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12799 s = ffebld_symter (ffebld_left (expr));
12800 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12801 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12802 && ! ffesymbol_is_f2c (s))
12803 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12804 && ! ffe_is_f2c_library ()))
12807 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12809 /* Requires special treatment. There's no POW_CC function
12810 in libg2c, so POW_ZZ is used, which means we always
12811 need a double-complex temp, not a single-complex. */
12812 kt = FFEINFO_kindtypeREAL2;
12814 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12815 /* The other ops don't need temps for complex operands. */
12818 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12819 REAL(C). See 19990325-0.f, routine `check', for cases. */
12820 tempvar = ffecom_make_tempvar ("complex",
12822 [FFEINFO_basictypeCOMPLEX][kt],
12823 FFETARGET_charactersizeNONE,
12827 case FFEINFO_basictypeCHARACTER:
12828 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12831 if (sz == FFETARGET_charactersizeNONE)
12832 /* ~~Kludge alert! This should someday be fixed. */
12835 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12844 case FFEBLD_opPOWER:
12847 tree rtmp, ltmp, result;
12849 ltype = ffecom_type_expr (ffebld_left (expr));
12850 rtype = ffecom_type_expr (ffebld_right (expr));
12852 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12853 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12854 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12856 tempvar = make_tree_vec (3);
12857 TREE_VEC_ELT (tempvar, 0) = rtmp;
12858 TREE_VEC_ELT (tempvar, 1) = ltmp;
12859 TREE_VEC_ELT (tempvar, 2) = result;
12864 case FFEBLD_opCONCATENATE:
12866 /* This gets special handling, because only one set of temps
12867 is needed for a tree of these -- the tree is treated as
12868 a flattened list of concatenations when generating code. */
12870 ffecomConcatList_ catlist;
12871 tree ltmp, itmp, result;
12875 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12876 count = ffecom_concat_list_count_ (catlist);
12881 = ffecom_make_tempvar ("concat_len",
12882 ffecom_f2c_ftnlen_type_node,
12883 FFETARGET_charactersizeNONE, count);
12885 = ffecom_make_tempvar ("concat_item",
12886 ffecom_f2c_address_type_node,
12887 FFETARGET_charactersizeNONE, count);
12889 = ffecom_make_tempvar ("concat_res",
12891 ffecom_concat_list_maxlen_ (catlist),
12894 tempvar = make_tree_vec (3);
12895 TREE_VEC_ELT (tempvar, 0) = ltmp;
12896 TREE_VEC_ELT (tempvar, 1) = itmp;
12897 TREE_VEC_ELT (tempvar, 2) = result;
12900 for (i = 0; i < count; ++i)
12901 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12904 ffecom_concat_list_kill_ (catlist);
12908 ffebld_nonter_set_hook (expr, tempvar);
12909 current_binding_level->prep_state = 1;
12914 case FFEBLD_opCONVERT:
12915 if (bt == FFEINFO_basictypeCHARACTER
12916 && ((ffebld_size_known (ffebld_left (expr))
12917 == FFETARGET_charactersizeNONE)
12918 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12919 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12925 ffebld_nonter_set_hook (expr, tempvar);
12926 current_binding_level->prep_state = 1;
12929 /* Prepare subexpressions for this expr. */
12931 switch (ffebld_op (expr))
12933 case FFEBLD_opPERCENT_LOC:
12934 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12937 case FFEBLD_opPERCENT_VAL:
12938 case FFEBLD_opPERCENT_REF:
12939 ffecom_prepare_expr (ffebld_left (expr));
12942 case FFEBLD_opPERCENT_DESCR:
12943 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12946 case FFEBLD_opITEM:
12952 item = ffebld_trail (item))
12953 if (ffebld_head (item) != NULL)
12954 ffecom_prepare_expr (ffebld_head (item));
12959 /* Need to handle character conversion specially. */
12960 switch (ffebld_arity (expr))
12963 ffecom_prepare_expr (ffebld_left (expr));
12964 ffecom_prepare_expr (ffebld_right (expr));
12968 ffecom_prepare_expr (ffebld_left (expr));
12979 /* Prepare expression for reading and writing.
12981 Like ffecom_prepare_expr, except for expressions to be evaluated
12982 via ffecom_expr_rw. */
12985 ffecom_prepare_expr_rw (tree type, ffebld expr)
12987 /* This is all we support for now. */
12988 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12990 /* ~~For now, it seems to be the same thing. */
12991 ffecom_prepare_expr (expr);
12995 /* Prepare expression for writing.
12997 Like ffecom_prepare_expr, except for expressions to be evaluated
12998 via ffecom_expr_w. */
13001 ffecom_prepare_expr_w (tree type, ffebld expr)
13003 /* This is all we support for now. */
13004 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13006 /* ~~For now, it seems to be the same thing. */
13007 ffecom_prepare_expr (expr);
13011 /* Prepare expression for returning.
13013 Like ffecom_prepare_expr, except for expressions to be evaluated
13014 via ffecom_return_expr. */
13017 ffecom_prepare_return_expr (ffebld expr)
13019 assert (current_binding_level->prep_state < 2);
13021 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13022 && ffecom_is_altreturning_
13024 ffecom_prepare_expr (expr);
13027 /* Prepare pointer to expression.
13029 Like ffecom_prepare_expr, except for expressions to be evaluated
13030 via ffecom_ptr_to_expr. */
13033 ffecom_prepare_ptr_to_expr (ffebld expr)
13035 /* ~~For now, it seems to be the same thing. */
13036 ffecom_prepare_expr (expr);
13040 /* Transform expression into constant pointer-to-expression tree.
13042 If the expression can be transformed into a pointer-to-expression tree
13043 that is constant, that is done, and the tree returned. Else NULL_TREE
13046 That way, a caller can attempt to provide compile-time initialization
13047 of a variable and, if that fails, *then* choose to start a new block
13048 and resort to using temporaries, as appropriate. */
13051 ffecom_ptr_to_const_expr (ffebld expr)
13054 return integer_zero_node;
13056 if (ffebld_op (expr) == FFEBLD_opANY)
13057 return error_mark_node;
13059 if (ffebld_arity (expr) == 0
13060 && (ffebld_op (expr) != FFEBLD_opSYMTER
13061 || ffebld_where (expr) == FFEINFO_whereCOMMON
13062 || ffebld_where (expr) == FFEINFO_whereGLOBAL
13063 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13067 t = ffecom_ptr_to_expr (expr);
13068 assert (TREE_CONSTANT (t));
13075 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13077 tree rtn; // NULL_TREE means use expand_null_return()
13078 ffebld expr; // NULL if no alt return expr to RETURN stmt
13079 rtn = ffecom_return_expr(expr);
13081 Based on the program unit type and other info (like return function
13082 type, return master function type when alternate ENTRY points,
13083 whether subroutine has any alternate RETURN points, etc), returns the
13084 appropriate expression to be returned to the caller, or NULL_TREE
13085 meaning no return value or the caller expects it to be returned somewhere
13086 else (which is handled by other parts of this module). */
13088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13090 ffecom_return_expr (ffebld expr)
13094 switch (ffecom_primary_entry_kind_)
13096 case FFEINFO_kindPROGRAM:
13097 case FFEINFO_kindBLOCKDATA:
13101 case FFEINFO_kindSUBROUTINE:
13102 if (!ffecom_is_altreturning_)
13103 rtn = NULL_TREE; /* No alt returns, never an expr. */
13104 else if (expr == NULL)
13105 rtn = integer_zero_node;
13107 rtn = ffecom_expr (expr);
13110 case FFEINFO_kindFUNCTION:
13111 if ((ffecom_multi_retval_ != NULL_TREE)
13112 || (ffesymbol_basictype (ffecom_primary_entry_)
13113 == FFEINFO_basictypeCHARACTER)
13114 || ((ffesymbol_basictype (ffecom_primary_entry_)
13115 == FFEINFO_basictypeCOMPLEX)
13116 && (ffecom_num_entrypoints_ == 0)
13117 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13118 { /* Value is returned by direct assignment
13119 into (implicit) dummy. */
13123 rtn = ffecom_func_result_;
13125 /* Spurious error if RETURN happens before first reference! So elide
13126 this code. In particular, for debugging registry, rtn should always
13127 be non-null after all, but TREE_USED won't be set until we encounter
13128 a reference in the code. Perfectly okay (but weird) code that,
13129 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13130 this diagnostic for no reason. Have people use -O -Wuninitialized
13131 and leave it to the back end to find obviously weird cases. */
13133 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13134 situation; if the return value has never been referenced, it won't
13135 have a tree under 2pass mode. */
13136 if ((rtn == NULL_TREE)
13137 || !TREE_USED (rtn))
13139 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13140 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13141 ffesymbol_where_column (ffecom_primary_entry_));
13142 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13143 (ffecom_primary_entry_)));
13150 assert ("bad unit kind" == NULL);
13151 case FFEINFO_kindANY:
13152 rtn = error_mark_node;
13160 /* Do save_expr only if tree is not error_mark_node. */
13162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13164 ffecom_save_tree (tree t)
13166 return save_expr (t);
13170 /* Start a compound statement (block). */
13172 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13174 ffecom_start_compstmt (void)
13176 bison_rule_pushlevel_ ();
13178 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13180 /* Public entry point for front end to access start_decl. */
13182 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13184 ffecom_start_decl (tree decl, bool is_initialized)
13186 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13187 return start_decl (decl, FALSE);
13191 /* ffecom_sym_commit -- Symbol's state being committed to reality
13194 ffecom_sym_commit(s);
13196 Does whatever the backend needs when a symbol is committed after having
13197 been backtrackable for a period of time. */
13199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13201 ffecom_sym_commit (ffesymbol s UNUSED)
13203 assert (!ffesymbol_retractable ());
13207 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13209 ffecom_sym_end_transition();
13211 Does backend-specific stuff and also calls ffest_sym_end_transition
13212 to do the necessary FFE stuff.
13214 Backtracking is never enabled when this fn is called, so don't worry
13218 ffecom_sym_end_transition (ffesymbol s)
13222 assert (!ffesymbol_retractable ());
13224 s = ffest_sym_end_transition (s);
13226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13227 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13228 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13230 ffecom_list_blockdata_
13231 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13232 FFEINTRIN_specNONE,
13233 FFEINTRIN_impNONE),
13234 ffecom_list_blockdata_);
13238 /* This is where we finally notice that a symbol has partial initialization
13239 and finalize it. */
13241 if (ffesymbol_accretion (s) != NULL)
13243 assert (ffesymbol_init (s) == NULL);
13244 ffecom_notify_init_symbol (s);
13246 else if (((st = ffesymbol_storage (s)) != NULL)
13247 && ((st = ffestorag_parent (st)) != NULL)
13248 && (ffestorag_accretion (st) != NULL))
13250 assert (ffestorag_init (st) == NULL);
13251 ffecom_notify_init_storage (st);
13254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13255 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13256 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13257 && (ffesymbol_storage (s) != NULL))
13259 ffecom_list_common_
13260 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13261 FFEINTRIN_specNONE,
13262 FFEINTRIN_impNONE),
13263 ffecom_list_common_);
13270 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13272 ffecom_sym_exec_transition();
13274 Does backend-specific stuff and also calls ffest_sym_exec_transition
13275 to do the necessary FFE stuff.
13277 See the long-winded description in ffecom_sym_learned for info
13278 on handling the situation where backtracking is inhibited. */
13281 ffecom_sym_exec_transition (ffesymbol s)
13283 s = ffest_sym_exec_transition (s);
13288 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13291 s = ffecom_sym_learned(s);
13293 Called when a new symbol is seen after the exec transition or when more
13294 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13295 it arrives here is that all its latest info is updated already, so its
13296 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13297 field filled in if its gone through here or exec_transition first, and
13300 The backend probably wants to check ffesymbol_retractable() to see if
13301 backtracking is in effect. If so, the FFE's changes to the symbol may
13302 be retracted (undone) or committed (ratified), at which time the
13303 appropriate ffecom_sym_retract or _commit function will be called
13306 If the backend has its own backtracking mechanism, great, use it so that
13307 committal is a simple operation. Though it doesn't make much difference,
13308 I suppose: the reason for tentative symbol evolution in the FFE is to
13309 enable error detection in weird incorrect statements early and to disable
13310 incorrect error detection on a correct statement. The backend is not
13311 likely to introduce any information that'll get involved in these
13312 considerations, so it is probably just fine that the implementation
13313 model for this fn and for _exec_transition is to not do anything
13314 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13315 and instead wait until ffecom_sym_commit is called (which it never
13316 will be as long as we're using ambiguity-detecting statement analysis in
13317 the FFE, which we are initially to shake out the code, but don't depend
13318 on this), otherwise go ahead and do whatever is needed.
13320 In essence, then, when this fn and _exec_transition get called while
13321 backtracking is enabled, a general mechanism would be to flag which (or
13322 both) of these were called (and in what order? neat question as to what
13323 might happen that I'm too lame to think through right now) and then when
13324 _commit is called reproduce the original calling sequence, if any, for
13325 the two fns (at which point backtracking will, of course, be disabled). */
13328 ffecom_sym_learned (ffesymbol s)
13330 ffestorag_exec_layout (s);
13335 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13338 ffecom_sym_retract(s);
13340 Does whatever the backend needs when a symbol is retracted after having
13341 been backtrackable for a period of time. */
13343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13345 ffecom_sym_retract (ffesymbol s UNUSED)
13347 assert (!ffesymbol_retractable ());
13349 #if 0 /* GCC doesn't commit any backtrackable sins,
13350 so nothing needed here. */
13351 switch (ffesymbol_hook (s).state)
13353 case 0: /* nothing happened yet. */
13356 case 1: /* exec transition happened. */
13359 case 2: /* learned happened. */
13362 case 3: /* learned then exec. */
13365 case 4: /* exec then learned. */
13369 assert ("bad hook state" == NULL);
13376 /* Create temporary gcc label. */
13378 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13380 ffecom_temp_label ()
13383 static int mynumber = 0;
13385 glabel = build_decl (LABEL_DECL,
13386 ffecom_get_invented_identifier ("__g77_label_%d",
13389 DECL_CONTEXT (glabel) = current_function_decl;
13390 DECL_MODE (glabel) = VOIDmode;
13396 /* Return an expression that is usable as an arg in a conditional context
13397 (IF, DO WHILE, .NOT., and so on).
13399 Use the one provided for the back end as of >2.6.0. */
13401 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13403 ffecom_truth_value (tree expr)
13405 return truthvalue_conversion (expr);
13409 /* Return the inversion of a truth value (the inversion of what
13410 ffecom_truth_value builds).
13412 Apparently invert_truthvalue, which is properly in the back end, is
13413 enough for now, so just use it. */
13415 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13417 ffecom_truth_value_invert (tree expr)
13419 return invert_truthvalue (ffecom_truth_value (expr));
13424 /* Return the tree that is the type of the expression, as would be
13425 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13426 transforming the expression, generating temporaries, etc. */
13429 ffecom_type_expr (ffebld expr)
13431 ffeinfoBasictype bt;
13432 ffeinfoKindtype kt;
13435 assert (expr != NULL);
13437 bt = ffeinfo_basictype (ffebld_info (expr));
13438 kt = ffeinfo_kindtype (ffebld_info (expr));
13439 tree_type = ffecom_tree_type[bt][kt];
13441 switch (ffebld_op (expr))
13443 case FFEBLD_opCONTER:
13444 case FFEBLD_opSYMTER:
13445 case FFEBLD_opARRAYREF:
13446 case FFEBLD_opUPLUS:
13447 case FFEBLD_opPAREN:
13448 case FFEBLD_opUMINUS:
13450 case FFEBLD_opSUBTRACT:
13451 case FFEBLD_opMULTIPLY:
13452 case FFEBLD_opDIVIDE:
13453 case FFEBLD_opPOWER:
13455 case FFEBLD_opFUNCREF:
13456 case FFEBLD_opSUBRREF:
13460 case FFEBLD_opNEQV:
13462 case FFEBLD_opCONVERT:
13469 case FFEBLD_opPERCENT_LOC:
13472 case FFEBLD_opACCTER:
13473 case FFEBLD_opARRTER:
13474 case FFEBLD_opITEM:
13475 case FFEBLD_opSTAR:
13476 case FFEBLD_opBOUNDS:
13477 case FFEBLD_opREPEAT:
13478 case FFEBLD_opLABTER:
13479 case FFEBLD_opLABTOK:
13480 case FFEBLD_opIMPDO:
13481 case FFEBLD_opCONCATENATE:
13482 case FFEBLD_opSUBSTR:
13484 assert ("bad op for ffecom_type_expr" == NULL);
13485 /* Fall through. */
13487 return error_mark_node;
13491 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13493 If the PARM_DECL already exists, return it, else create it. It's an
13494 integer_type_node argument for the master function that implements a
13495 subroutine or function with more than one entrypoint and is bound at
13496 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13497 first ENTRY statement, and so on). */
13499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13501 ffecom_which_entrypoint_decl ()
13503 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13505 return ffecom_which_entrypoint_decl_;
13510 /* The following sections consists of private and public functions
13511 that have the same names and perform roughly the same functions
13512 as counterparts in the C front end. Changes in the C front end
13513 might affect how things should be done here. Only functions
13514 needed by the back end should be public here; the rest should
13515 be private (static in the C sense). Functions needed by other
13516 g77 front-end modules should be accessed by them via public
13517 ffecom_* names, which should themselves call private versions
13518 in this section so the private versions are easy to recognize
13519 when upgrading to a new gcc and finding interesting changes
13522 Functions named after rule "foo:" in c-parse.y are named
13523 "bison_rule_foo_" so they are easy to find. */
13525 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13528 bison_rule_pushlevel_ ()
13530 emit_line_note (input_filename, lineno);
13532 clear_last_expr ();
13533 expand_start_bindings (0);
13537 bison_rule_compstmt_ ()
13540 int keep = kept_level_p ();
13542 /* Make the temps go away. */
13544 current_binding_level->names = NULL_TREE;
13546 emit_line_note (input_filename, lineno);
13547 expand_end_bindings (getdecls (), keep, 0);
13548 t = poplevel (keep, 1, 0);
13553 /* Return a definition for a builtin function named NAME and whose data type
13554 is TYPE. TYPE should be a function type with argument types.
13555 FUNCTION_CODE tells later passes how to compile calls to this function.
13556 See tree.h for its possible values.
13558 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13559 the name to be called if we can't opencode the function. */
13562 builtin_function (const char *name, tree type, int function_code,
13563 enum built_in_class class,
13564 const char *library_name)
13566 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13567 DECL_EXTERNAL (decl) = 1;
13568 TREE_PUBLIC (decl) = 1;
13570 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13571 make_decl_rtl (decl, NULL_PTR);
13573 DECL_BUILT_IN_CLASS (decl) = class;
13574 DECL_FUNCTION_CODE (decl) = function_code;
13579 /* Handle when a new declaration NEWDECL
13580 has the same name as an old one OLDDECL
13581 in the same binding contour.
13582 Prints an error message if appropriate.
13584 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13585 Otherwise, return 0. */
13588 duplicate_decls (tree newdecl, tree olddecl)
13590 int types_match = 1;
13591 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13592 && DECL_INITIAL (newdecl) != 0);
13593 tree oldtype = TREE_TYPE (olddecl);
13594 tree newtype = TREE_TYPE (newdecl);
13596 if (olddecl == newdecl)
13599 if (TREE_CODE (newtype) == ERROR_MARK
13600 || TREE_CODE (oldtype) == ERROR_MARK)
13603 /* New decl is completely inconsistent with the old one =>
13604 tell caller to replace the old one.
13605 This is always an error except in the case of shadowing a builtin. */
13606 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13609 /* For real parm decl following a forward decl,
13610 return 1 so old decl will be reused. */
13611 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13612 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13615 /* The new declaration is the same kind of object as the old one.
13616 The declarations may partially match. Print warnings if they don't
13617 match enough. Ultimately, copy most of the information from the new
13618 decl to the old one, and keep using the old one. */
13620 if (TREE_CODE (olddecl) == FUNCTION_DECL
13621 && DECL_BUILT_IN (olddecl))
13623 /* A function declaration for a built-in function. */
13624 if (!TREE_PUBLIC (newdecl))
13626 else if (!types_match)
13628 /* Accept the return type of the new declaration if same modes. */
13629 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13630 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13632 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13634 /* Function types may be shared, so we can't just modify
13635 the return type of olddecl's function type. */
13637 = build_function_type (newreturntype,
13638 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13642 TREE_TYPE (olddecl) = newtype;
13648 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13649 && DECL_SOURCE_LINE (olddecl) == 0)
13651 /* A function declaration for a predeclared function
13652 that isn't actually built in. */
13653 if (!TREE_PUBLIC (newdecl))
13655 else if (!types_match)
13657 /* If the types don't match, preserve volatility indication.
13658 Later on, we will discard everything else about the
13659 default declaration. */
13660 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13664 /* Copy all the DECL_... slots specified in the new decl
13665 except for any that we copy here from the old type.
13667 Past this point, we don't change OLDTYPE and NEWTYPE
13668 even if we change the types of NEWDECL and OLDDECL. */
13672 /* Merge the data types specified in the two decls. */
13673 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13674 TREE_TYPE (newdecl)
13675 = TREE_TYPE (olddecl)
13676 = TREE_TYPE (newdecl);
13678 /* Lay the type out, unless already done. */
13679 if (oldtype != TREE_TYPE (newdecl))
13681 if (TREE_TYPE (newdecl) != error_mark_node)
13682 layout_type (TREE_TYPE (newdecl));
13683 if (TREE_CODE (newdecl) != FUNCTION_DECL
13684 && TREE_CODE (newdecl) != TYPE_DECL
13685 && TREE_CODE (newdecl) != CONST_DECL)
13686 layout_decl (newdecl, 0);
13690 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13691 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13692 DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13693 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13694 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13696 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13697 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13701 /* Keep the old rtl since we can safely use it. */
13702 DECL_RTL (newdecl) = DECL_RTL (olddecl);
13704 /* Merge the type qualifiers. */
13705 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13706 && !TREE_THIS_VOLATILE (newdecl))
13707 TREE_THIS_VOLATILE (olddecl) = 0;
13708 if (TREE_READONLY (newdecl))
13709 TREE_READONLY (olddecl) = 1;
13710 if (TREE_THIS_VOLATILE (newdecl))
13712 TREE_THIS_VOLATILE (olddecl) = 1;
13713 if (TREE_CODE (newdecl) == VAR_DECL)
13714 make_var_volatile (newdecl);
13717 /* Keep source location of definition rather than declaration.
13718 Likewise, keep decl at outer scope. */
13719 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13720 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13722 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13723 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13725 if (DECL_CONTEXT (olddecl) == 0
13726 && TREE_CODE (newdecl) != FUNCTION_DECL)
13727 DECL_CONTEXT (newdecl) = 0;
13730 /* Merge the unused-warning information. */
13731 if (DECL_IN_SYSTEM_HEADER (olddecl))
13732 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13733 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13734 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13736 /* Merge the initialization information. */
13737 if (DECL_INITIAL (newdecl) == 0)
13738 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13740 /* Merge the section attribute.
13741 We want to issue an error if the sections conflict but that must be
13742 done later in decl_attributes since we are called before attributes
13744 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13745 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13748 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13750 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13751 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13755 /* If cannot merge, then use the new type and qualifiers,
13756 and don't preserve the old rtl. */
13759 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13760 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13761 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13762 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13765 /* Merge the storage class information. */
13766 /* For functions, static overrides non-static. */
13767 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13769 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13770 /* This is since we don't automatically
13771 copy the attributes of NEWDECL into OLDDECL. */
13772 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13773 /* If this clears `static', clear it in the identifier too. */
13774 if (! TREE_PUBLIC (olddecl))
13775 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13777 if (DECL_EXTERNAL (newdecl))
13779 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13780 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13781 /* An extern decl does not override previous storage class. */
13782 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13786 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13787 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13790 /* If either decl says `inline', this fn is inline,
13791 unless its definition was passed already. */
13792 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13793 DECL_INLINE (olddecl) = 1;
13794 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13796 /* Get rid of any built-in function if new arg types don't match it
13797 or if we have a function definition. */
13798 if (TREE_CODE (newdecl) == FUNCTION_DECL
13799 && DECL_BUILT_IN (olddecl)
13800 && (!types_match || new_is_definition))
13802 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13803 DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13806 /* If redeclaring a builtin function, and not a definition,
13808 Also preserve various other info from the definition. */
13809 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13811 if (DECL_BUILT_IN (olddecl))
13813 DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13814 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13817 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13819 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13820 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13821 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13822 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13825 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13826 But preserve olddecl's DECL_UID. */
13828 register unsigned olddecl_uid = DECL_UID (olddecl);
13830 memcpy ((char *) olddecl + sizeof (struct tree_common),
13831 (char *) newdecl + sizeof (struct tree_common),
13832 sizeof (struct tree_decl) - sizeof (struct tree_common));
13833 DECL_UID (olddecl) = olddecl_uid;
13839 /* Finish processing of a declaration;
13840 install its initial value.
13841 If the length of an array type is not known before,
13842 it must be determined now, from the initial value, or it is an error. */
13845 finish_decl (tree decl, tree init, bool is_top_level)
13847 register tree type = TREE_TYPE (decl);
13848 int was_incomplete = (DECL_SIZE (decl) == 0);
13849 bool at_top_level = (current_binding_level == global_binding_level);
13850 bool top_level = is_top_level || at_top_level;
13852 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13854 assert (!is_top_level || !at_top_level);
13856 if (TREE_CODE (decl) == PARM_DECL)
13857 assert (init == NULL_TREE);
13858 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13859 overlaps DECL_ARG_TYPE. */
13860 else if (init == NULL_TREE)
13861 assert (DECL_INITIAL (decl) == NULL_TREE);
13863 assert (DECL_INITIAL (decl) == error_mark_node);
13865 if (init != NULL_TREE)
13867 if (TREE_CODE (decl) != TYPE_DECL)
13868 DECL_INITIAL (decl) = init;
13871 /* typedef foo = bar; store the type of bar as the type of foo. */
13872 TREE_TYPE (decl) = TREE_TYPE (init);
13873 DECL_INITIAL (decl) = init = 0;
13877 /* Deduce size of array from initialization, if not already known */
13879 if (TREE_CODE (type) == ARRAY_TYPE
13880 && TYPE_DOMAIN (type) == 0
13881 && TREE_CODE (decl) != TYPE_DECL)
13883 assert (top_level);
13884 assert (was_incomplete);
13886 layout_decl (decl, 0);
13889 if (TREE_CODE (decl) == VAR_DECL)
13891 if (DECL_SIZE (decl) == NULL_TREE
13892 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13893 layout_decl (decl, 0);
13895 if (DECL_SIZE (decl) == NULL_TREE
13896 && (TREE_STATIC (decl)
13898 /* A static variable with an incomplete type is an error if it is
13899 initialized. Also if it is not file scope. Otherwise, let it
13900 through, but if it is not `extern' then it may cause an error
13902 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13904 /* An automatic variable with an incomplete type is an error. */
13905 !DECL_EXTERNAL (decl)))
13907 assert ("storage size not known" == NULL);
13911 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13912 && (DECL_SIZE (decl) != 0)
13913 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13915 assert ("storage size not constant" == NULL);
13920 /* Output the assembler code and/or RTL code for variables and functions,
13921 unless the type is an undefined structure or union. If not, it will get
13922 done when the type is completed. */
13924 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13926 rest_of_decl_compilation (decl, NULL,
13927 DECL_CONTEXT (decl) == 0,
13930 if (DECL_CONTEXT (decl) != 0)
13932 /* Recompute the RTL of a local array now if it used to be an
13933 incomplete type. */
13935 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13937 /* If we used it already as memory, it must stay in memory. */
13938 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13939 /* If it's still incomplete now, no init will save it. */
13940 if (DECL_SIZE (decl) == 0)
13941 DECL_INITIAL (decl) = 0;
13942 expand_decl (decl);
13944 /* Compute and store the initial value. */
13945 if (TREE_CODE (decl) != FUNCTION_DECL)
13946 expand_decl_init (decl);
13949 else if (TREE_CODE (decl) == TYPE_DECL)
13951 rest_of_decl_compilation (decl, NULL_PTR,
13952 DECL_CONTEXT (decl) == 0,
13956 /* At the end of a declaration, throw away any variable type sizes of types
13957 defined inside that declaration. There is no use computing them in the
13958 following function definition. */
13959 if (current_binding_level == global_binding_level)
13960 get_pending_sizes ();
13963 /* Finish up a function declaration and compile that function
13964 all the way to assembler language output. The free the storage
13965 for the function definition.
13967 This is called after parsing the body of the function definition.
13969 NESTED is nonzero if the function being finished is nested in another. */
13972 finish_function (int nested)
13974 register tree fndecl = current_function_decl;
13976 assert (fndecl != NULL_TREE);
13977 if (TREE_CODE (fndecl) != ERROR_MARK)
13980 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13982 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13985 /* TREE_READONLY (fndecl) = 1;
13986 This caused &foo to be of type ptr-to-const-function
13987 which then got a warning when stored in a ptr-to-function variable. */
13989 poplevel (1, 0, 1);
13991 if (TREE_CODE (fndecl) != ERROR_MARK)
13993 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13995 /* Must mark the RESULT_DECL as being in this function. */
13997 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13999 /* Obey `register' declarations if `setjmp' is called in this fn. */
14000 /* Generate rtl for function exit. */
14001 expand_function_end (input_filename, lineno, 0);
14003 /* If this is a nested function, protect the local variables in the stack
14004 above us from being collected while we're compiling this function. */
14006 ggc_push_context ();
14008 /* Run the optimizers and output the assembler code for this function. */
14009 rest_of_compilation (fndecl);
14011 /* Undo the GC context switch. */
14013 ggc_pop_context ();
14016 if (TREE_CODE (fndecl) != ERROR_MARK
14018 && DECL_SAVED_INSNS (fndecl) == 0)
14020 /* Stop pointing to the local nodes about to be freed. */
14021 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14022 function definition. */
14023 /* For a nested function, this is done in pop_f_function_context. */
14024 /* If rest_of_compilation set this to 0, leave it 0. */
14025 if (DECL_INITIAL (fndecl) != 0)
14026 DECL_INITIAL (fndecl) = error_mark_node;
14027 DECL_ARGUMENTS (fndecl) = 0;
14032 /* Let the error reporting routines know that we're outside a function.
14033 For a nested function, this value is used in pop_c_function_context
14034 and then reset via pop_function_context. */
14035 ffecom_outer_function_decl_ = current_function_decl = NULL;
14039 /* Plug-in replacement for identifying the name of a decl and, for a
14040 function, what we call it in diagnostics. For now, "program unit"
14041 should suffice, since it's a bit of a hassle to figure out which
14042 of several kinds of things it is. Note that it could conceivably
14043 be a statement function, which probably isn't really a program unit
14044 per se, but if that comes up, it should be easy to check (being a
14045 nested function and all). */
14047 static const char *
14048 lang_printable_name (tree decl, int v)
14050 /* Just to keep GCC quiet about the unused variable.
14051 In theory, differing values of V should produce different
14056 if (TREE_CODE (decl) == ERROR_MARK)
14057 return "erroneous code";
14058 return IDENTIFIER_POINTER (DECL_NAME (decl));
14062 /* g77's function to print out name of current function that caused
14067 lang_print_error_function (const char *file)
14069 static ffeglobal last_g = NULL;
14070 static ffesymbol last_s = NULL;
14075 if ((ffecom_primary_entry_ == NULL)
14076 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14084 g = ffesymbol_global (ffecom_primary_entry_);
14085 if (ffecom_nested_entry_ == NULL)
14087 s = ffecom_primary_entry_;
14088 switch (ffesymbol_kind (s))
14090 case FFEINFO_kindFUNCTION:
14094 case FFEINFO_kindSUBROUTINE:
14095 kind = "subroutine";
14098 case FFEINFO_kindPROGRAM:
14102 case FFEINFO_kindBLOCKDATA:
14103 kind = "block-data";
14107 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14113 s = ffecom_nested_entry_;
14114 kind = "statement function";
14118 if ((last_g != g) || (last_s != s))
14121 fprintf (stderr, "%s: ", file);
14124 fprintf (stderr, "Outside of any program unit:\n");
14127 const char *name = ffesymbol_text (s);
14129 fprintf (stderr, "In %s `%s':\n", kind, name);
14138 /* Similar to `lookup_name' but look only at current binding level. */
14141 lookup_name_current_level (tree name)
14145 if (current_binding_level == global_binding_level)
14146 return IDENTIFIER_GLOBAL_VALUE (name);
14148 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14151 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14152 if (DECL_NAME (t) == name)
14158 /* Create a new `struct binding_level'. */
14160 static struct binding_level *
14161 make_binding_level ()
14164 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14167 /* Save and restore the variables in this file and elsewhere
14168 that keep track of the progress of compilation of the current function.
14169 Used for nested functions. */
14173 struct f_function *next;
14175 tree shadowed_labels;
14176 struct binding_level *binding_level;
14179 struct f_function *f_function_chain;
14181 /* Restore the variables used during compilation of a C function. */
14184 pop_f_function_context ()
14186 struct f_function *p = f_function_chain;
14189 /* Bring back all the labels that were shadowed. */
14190 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14191 if (DECL_NAME (TREE_VALUE (link)) != 0)
14192 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14193 = TREE_VALUE (link);
14195 if (current_function_decl != error_mark_node
14196 && DECL_SAVED_INSNS (current_function_decl) == 0)
14198 /* Stop pointing to the local nodes about to be freed. */
14199 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14200 function definition. */
14201 DECL_INITIAL (current_function_decl) = error_mark_node;
14202 DECL_ARGUMENTS (current_function_decl) = 0;
14205 pop_function_context ();
14207 f_function_chain = p->next;
14209 named_labels = p->named_labels;
14210 shadowed_labels = p->shadowed_labels;
14211 current_binding_level = p->binding_level;
14216 /* Save and reinitialize the variables
14217 used during compilation of a C function. */
14220 push_f_function_context ()
14222 struct f_function *p
14223 = (struct f_function *) xmalloc (sizeof (struct f_function));
14225 push_function_context ();
14227 p->next = f_function_chain;
14228 f_function_chain = p;
14230 p->named_labels = named_labels;
14231 p->shadowed_labels = shadowed_labels;
14232 p->binding_level = current_binding_level;
14236 push_parm_decl (tree parm)
14238 int old_immediate_size_expand = immediate_size_expand;
14240 /* Don't try computing parm sizes now -- wait till fn is called. */
14242 immediate_size_expand = 0;
14244 /* Fill in arg stuff. */
14246 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14247 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14248 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
14250 parm = pushdecl (parm);
14252 immediate_size_expand = old_immediate_size_expand;
14254 finish_decl (parm, NULL_TREE, FALSE);
14257 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14260 pushdecl_top_level (x)
14264 register struct binding_level *b = current_binding_level;
14265 register tree f = current_function_decl;
14267 current_binding_level = global_binding_level;
14268 current_function_decl = NULL_TREE;
14270 current_binding_level = b;
14271 current_function_decl = f;
14275 /* Store the list of declarations of the current level.
14276 This is done for the parameter declarations of a function being defined,
14277 after they are modified in the light of any missing parameters. */
14283 return current_binding_level->names = decls;
14286 /* Store the parameter declarations into the current function declaration.
14287 This is called after parsing the parameter declarations, before
14288 digesting the body of the function.
14290 For an old-style definition, modify the function's type
14291 to specify at least the number of arguments. */
14294 store_parm_decls (int is_main_program UNUSED)
14296 register tree fndecl = current_function_decl;
14298 if (fndecl == error_mark_node)
14301 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14302 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14304 /* Initialize the RTL code for the function. */
14306 init_function_start (fndecl, input_filename, lineno);
14308 /* Set up parameters and prepare for return, for the function. */
14310 expand_function_start (fndecl, 0);
14314 start_decl (tree decl, bool is_top_level)
14317 bool at_top_level = (current_binding_level == global_binding_level);
14318 bool top_level = is_top_level || at_top_level;
14320 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14322 assert (!is_top_level || !at_top_level);
14324 if (DECL_INITIAL (decl) != NULL_TREE)
14326 assert (DECL_INITIAL (decl) == error_mark_node);
14327 assert (!DECL_EXTERNAL (decl));
14329 else if (top_level)
14330 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14332 /* For Fortran, we by default put things in .common when possible. */
14333 DECL_COMMON (decl) = 1;
14335 /* Add this decl to the current binding level. TEM may equal DECL or it may
14336 be a previous decl of the same name. */
14338 tem = pushdecl_top_level (decl);
14340 tem = pushdecl (decl);
14342 /* For a local variable, define the RTL now. */
14344 /* But not if this is a duplicate decl and we preserved the rtl from the
14345 previous one (which may or may not happen). */
14346 && DECL_RTL (tem) == 0)
14348 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14350 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14351 && DECL_INITIAL (tem) != 0)
14358 /* Create the FUNCTION_DECL for a function definition.
14359 DECLSPECS and DECLARATOR are the parts of the declaration;
14360 they describe the function's name and the type it returns,
14361 but twisted together in a fashion that parallels the syntax of C.
14363 This function creates a binding context for the function body
14364 as well as setting up the FUNCTION_DECL in current_function_decl.
14366 Returns 1 on success. If the DECLARATOR is not suitable for a function
14367 (it defines a datum instead), we return 0, which tells
14368 yyparse to report a parse error.
14370 NESTED is nonzero for a function nested within another function. */
14373 start_function (tree name, tree type, int nested, int public)
14377 int old_immediate_size_expand = immediate_size_expand;
14380 shadowed_labels = 0;
14382 /* Don't expand any sizes in the return type of the function. */
14383 immediate_size_expand = 0;
14388 assert (current_function_decl != NULL_TREE);
14389 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14393 assert (current_function_decl == NULL_TREE);
14396 if (TREE_CODE (type) == ERROR_MARK)
14397 decl1 = current_function_decl = error_mark_node;
14400 decl1 = build_decl (FUNCTION_DECL,
14403 TREE_PUBLIC (decl1) = public ? 1 : 0;
14405 DECL_INLINE (decl1) = 1;
14406 TREE_STATIC (decl1) = 1;
14407 DECL_EXTERNAL (decl1) = 0;
14409 announce_function (decl1);
14411 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14412 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14413 DECL_INITIAL (decl1) = error_mark_node;
14415 /* Record the decl so that the function name is defined. If we already have
14416 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14418 current_function_decl = pushdecl (decl1);
14422 ffecom_outer_function_decl_ = current_function_decl;
14425 current_binding_level->prep_state = 2;
14427 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14429 make_decl_rtl (current_function_decl, NULL);
14431 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14432 DECL_RESULT (current_function_decl)
14433 = build_decl (RESULT_DECL, NULL_TREE, restype);
14436 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14437 TREE_ADDRESSABLE (current_function_decl) = 1;
14439 immediate_size_expand = old_immediate_size_expand;
14442 /* Here are the public functions the GNU back end needs. */
14445 convert (type, expr)
14448 register tree e = expr;
14449 register enum tree_code code = TREE_CODE (type);
14451 if (type == TREE_TYPE (e)
14452 || TREE_CODE (e) == ERROR_MARK)
14454 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14455 return fold (build1 (NOP_EXPR, type, e));
14456 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14457 || code == ERROR_MARK)
14458 return error_mark_node;
14459 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14461 assert ("void value not ignored as it ought to be" == NULL);
14462 return error_mark_node;
14464 if (code == VOID_TYPE)
14465 return build1 (CONVERT_EXPR, type, e);
14466 if ((code != RECORD_TYPE)
14467 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14468 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14470 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14471 return fold (convert_to_integer (type, e));
14472 if (code == POINTER_TYPE)
14473 return fold (convert_to_pointer (type, e));
14474 if (code == REAL_TYPE)
14475 return fold (convert_to_real (type, e));
14476 if (code == COMPLEX_TYPE)
14477 return fold (convert_to_complex (type, e));
14478 if (code == RECORD_TYPE)
14479 return fold (ffecom_convert_to_complex_ (type, e));
14481 assert ("conversion to non-scalar type requested" == NULL);
14482 return error_mark_node;
14485 /* integrate_decl_tree calls this function, but since we don't use the
14486 DECL_LANG_SPECIFIC field, this is a no-op. */
14489 copy_lang_decl (node)
14494 /* Return the list of declarations of the current level.
14495 Note that this list is in reverse order unless/until
14496 you nreverse it; and when you do nreverse it, you must
14497 store the result back using `storedecls' or you will lose. */
14502 return current_binding_level->names;
14505 /* Nonzero if we are currently in the global binding level. */
14508 global_bindings_p ()
14510 return current_binding_level == global_binding_level;
14513 /* Print an error message for invalid use of an incomplete type.
14514 VALUE is the expression that was used (or 0 if that isn't known)
14515 and TYPE is the type that was invalid. */
14518 incomplete_type_error (value, type)
14522 if (TREE_CODE (type) == ERROR_MARK)
14525 assert ("incomplete type?!?" == NULL);
14528 /* Mark ARG for GC. */
14530 mark_binding_level (void *arg)
14532 struct binding_level *level = *(struct binding_level **) arg;
14536 ggc_mark_tree (level->names);
14537 ggc_mark_tree (level->blocks);
14538 ggc_mark_tree (level->this_block);
14539 level = level->level_chain;
14544 init_decl_processing ()
14546 static tree *const tree_roots[] = {
14547 ¤t_function_decl,
14549 &ffecom_tree_fun_type_void,
14550 &ffecom_integer_zero_node,
14551 &ffecom_integer_one_node,
14552 &ffecom_tree_subr_type,
14553 &ffecom_tree_ptr_to_subr_type,
14554 &ffecom_tree_blockdata_type,
14555 &ffecom_tree_xargc_,
14556 &ffecom_f2c_integer_type_node,
14557 &ffecom_f2c_ptr_to_integer_type_node,
14558 &ffecom_f2c_address_type_node,
14559 &ffecom_f2c_real_type_node,
14560 &ffecom_f2c_ptr_to_real_type_node,
14561 &ffecom_f2c_doublereal_type_node,
14562 &ffecom_f2c_complex_type_node,
14563 &ffecom_f2c_doublecomplex_type_node,
14564 &ffecom_f2c_longint_type_node,
14565 &ffecom_f2c_logical_type_node,
14566 &ffecom_f2c_flag_type_node,
14567 &ffecom_f2c_ftnlen_type_node,
14568 &ffecom_f2c_ftnlen_zero_node,
14569 &ffecom_f2c_ftnlen_one_node,
14570 &ffecom_f2c_ftnlen_two_node,
14571 &ffecom_f2c_ptr_to_ftnlen_type_node,
14572 &ffecom_f2c_ftnint_type_node,
14573 &ffecom_f2c_ptr_to_ftnint_type_node,
14574 &ffecom_outer_function_decl_,
14575 &ffecom_previous_function_decl_,
14576 &ffecom_which_entrypoint_decl_,
14577 &ffecom_float_zero_,
14578 &ffecom_float_half_,
14579 &ffecom_double_zero_,
14580 &ffecom_double_half_,
14581 &ffecom_func_result_,
14582 &ffecom_func_length_,
14583 &ffecom_multi_type_node_,
14584 &ffecom_multi_retval_,
14592 /* Record our roots. */
14593 for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14594 ggc_add_tree_root (tree_roots[i], 1);
14595 ggc_add_tree_root (&ffecom_tree_type[0][0],
14596 FFEINFO_basictype*FFEINFO_kindtype);
14597 ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14598 FFEINFO_basictype*FFEINFO_kindtype);
14599 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14600 FFEINFO_basictype*FFEINFO_kindtype);
14601 ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14602 ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
14603 mark_binding_level);
14604 ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14605 mark_binding_level);
14606 ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14612 init_parse (filename)
14613 const char *filename;
14615 /* Open input file. */
14616 if (filename == 0 || !strcmp (filename, "-"))
14619 filename = "stdin";
14622 finput = fopen (filename, "r");
14624 pfatal_with_name (filename);
14626 #ifdef IO_BUFFER_SIZE
14627 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14630 /* Make identifier nodes long enough for the language-specific slots. */
14631 set_identifier_size (sizeof (struct lang_identifier));
14632 decl_printable_name = lang_printable_name;
14634 print_error_function = lang_print_error_function;
14646 /* Delete the node BLOCK from the current binding level.
14647 This is used for the block inside a stmt expr ({...})
14648 so that the block can be reinserted where appropriate. */
14651 delete_block (block)
14655 if (current_binding_level->blocks == block)
14656 current_binding_level->blocks = TREE_CHAIN (block);
14657 for (t = current_binding_level->blocks; t;)
14659 if (TREE_CHAIN (t) == block)
14660 TREE_CHAIN (t) = TREE_CHAIN (block);
14662 t = TREE_CHAIN (t);
14664 TREE_CHAIN (block) = NULL;
14665 /* Clear TREE_USED which is always set by poplevel.
14666 The flag is set again if insert_block is called. */
14667 TREE_USED (block) = 0;
14671 insert_block (block)
14674 TREE_USED (block) = 1;
14675 current_binding_level->blocks
14676 = chainon (current_binding_level->blocks, block);
14679 /* Each front end provides its own. */
14680 static void ffe_init PARAMS ((void));
14681 static void ffe_finish PARAMS ((void));
14682 static void ffe_init_options PARAMS ((void));
14684 struct lang_hooks lang_hooks = {ffe_init,
14688 NULL /* post_options */};
14690 /* used by print-tree.c */
14693 lang_print_xnode (file, node, indent)
14703 ffe_terminate_0 ();
14705 if (ffe_is_ffedebug ())
14706 malloc_pool_display (malloc_pool_image ());
14715 /* Return the typed-based alias set for T, which may be an expression
14716 or a type. Return -1 if we don't do anything special. */
14719 lang_get_alias_set (t)
14720 tree t ATTRIBUTE_UNUSED;
14722 /* We do not wish to use alias-set based aliasing at all. Used in the
14723 extreme (every object with its own set, with equivalences recorded)
14724 it might be helpful, but there are problems when it comes to inlining.
14725 We get on ok with flag_argument_noalias, and alias-set aliasing does
14726 currently limit how stack slots can be reused, which is a lose. */
14731 ffe_init_options ()
14733 /* Set default options for Fortran. */
14734 flag_move_all_movables = 1;
14735 flag_reduce_all_givs = 1;
14736 flag_argument_noalias = 2;
14737 flag_errno_math = 0;
14738 flag_complex_divide_method = 1;
14744 /* If the file is output from cpp, it should contain a first line
14745 `# 1 "real-filename"', and the current design of gcc (toplev.c
14746 in particular and the way it sets up information relied on by
14747 INCLUDE) requires that we read this now, and store the
14748 "real-filename" info in master_input_filename. Ask the lexer
14749 to try doing this. */
14750 ffelex_hash_kludge (finput);
14754 mark_addressable (exp)
14757 register tree x = exp;
14759 switch (TREE_CODE (x))
14762 case COMPONENT_REF:
14764 x = TREE_OPERAND (x, 0);
14768 TREE_ADDRESSABLE (x) = 1;
14775 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14776 && DECL_NONLOCAL (x))
14778 if (TREE_PUBLIC (x))
14780 assert ("address of global register var requested" == NULL);
14783 assert ("address of register variable requested" == NULL);
14785 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14787 if (TREE_PUBLIC (x))
14789 assert ("address of global register var requested" == NULL);
14792 assert ("address of register var requested" == NULL);
14794 put_var_into_stack (x);
14797 case FUNCTION_DECL:
14798 TREE_ADDRESSABLE (x) = 1;
14799 #if 0 /* poplevel deals with this now. */
14800 if (DECL_CONTEXT (x) == 0)
14801 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14809 /* If DECL has a cleanup, build and return that cleanup here.
14810 This is a callback called by expand_expr. */
14813 maybe_build_cleanup (decl)
14816 /* There are no cleanups in Fortran. */
14820 /* Exit a binding level.
14821 Pop the level off, and restore the state of the identifier-decl mappings
14822 that were in effect when this level was entered.
14824 If KEEP is nonzero, this level had explicit declarations, so
14825 and create a "block" (a BLOCK node) for the level
14826 to record its declarations and subblocks for symbol table output.
14828 If FUNCTIONBODY is nonzero, this level is the body of a function,
14829 so create a block as if KEEP were set and also clear out all
14832 If REVERSE is nonzero, reverse the order of decls before putting
14833 them into the BLOCK. */
14836 poplevel (keep, reverse, functionbody)
14841 register tree link;
14842 /* The chain of decls was accumulated in reverse order.
14843 Put it into forward order, just for cleanliness. */
14845 tree subblocks = current_binding_level->blocks;
14848 int block_previously_created;
14850 /* Get the decls in the order they were written.
14851 Usually current_binding_level->names is in reverse order.
14852 But parameter decls were previously put in forward order. */
14855 current_binding_level->names
14856 = decls = nreverse (current_binding_level->names);
14858 decls = current_binding_level->names;
14860 /* Output any nested inline functions within this block
14861 if they weren't already output. */
14863 for (decl = decls; decl; decl = TREE_CHAIN (decl))
14864 if (TREE_CODE (decl) == FUNCTION_DECL
14865 && ! TREE_ASM_WRITTEN (decl)
14866 && DECL_INITIAL (decl) != 0
14867 && TREE_ADDRESSABLE (decl))
14869 /* If this decl was copied from a file-scope decl
14870 on account of a block-scope extern decl,
14871 propagate TREE_ADDRESSABLE to the file-scope decl.
14873 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14874 true, since then the decl goes through save_for_inline_copying. */
14875 if (DECL_ABSTRACT_ORIGIN (decl) != 0
14876 && DECL_ABSTRACT_ORIGIN (decl) != decl)
14877 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14878 else if (DECL_SAVED_INSNS (decl) != 0)
14880 push_function_context ();
14881 output_inline_function (decl);
14882 pop_function_context ();
14886 /* If there were any declarations or structure tags in that level,
14887 or if this level is a function body,
14888 create a BLOCK to record them for the life of this function. */
14891 block_previously_created = (current_binding_level->this_block != 0);
14892 if (block_previously_created)
14893 block = current_binding_level->this_block;
14894 else if (keep || functionbody)
14895 block = make_node (BLOCK);
14898 BLOCK_VARS (block) = decls;
14899 BLOCK_SUBBLOCKS (block) = subblocks;
14902 /* In each subblock, record that this is its superior. */
14904 for (link = subblocks; link; link = TREE_CHAIN (link))
14905 BLOCK_SUPERCONTEXT (link) = block;
14907 /* Clear out the meanings of the local variables of this level. */
14909 for (link = decls; link; link = TREE_CHAIN (link))
14911 if (DECL_NAME (link) != 0)
14913 /* If the ident. was used or addressed via a local extern decl,
14914 don't forget that fact. */
14915 if (DECL_EXTERNAL (link))
14917 if (TREE_USED (link))
14918 TREE_USED (DECL_NAME (link)) = 1;
14919 if (TREE_ADDRESSABLE (link))
14920 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14922 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14926 /* If the level being exited is the top level of a function,
14927 check over all the labels, and clear out the current
14928 (function local) meanings of their names. */
14932 /* If this is the top level block of a function,
14933 the vars are the function's parameters.
14934 Don't leave them in the BLOCK because they are
14935 found in the FUNCTION_DECL instead. */
14937 BLOCK_VARS (block) = 0;
14940 /* Pop the current level, and free the structure for reuse. */
14943 register struct binding_level *level = current_binding_level;
14944 current_binding_level = current_binding_level->level_chain;
14946 level->level_chain = free_binding_level;
14947 free_binding_level = level;
14950 /* Dispose of the block that we just made inside some higher level. */
14952 && current_function_decl != error_mark_node)
14953 DECL_INITIAL (current_function_decl) = block;
14956 if (!block_previously_created)
14957 current_binding_level->blocks
14958 = chainon (current_binding_level->blocks, block);
14960 /* If we did not make a block for the level just exited,
14961 any blocks made for inner levels
14962 (since they cannot be recorded as subblocks in that level)
14963 must be carried forward so they will later become subblocks
14964 of something else. */
14965 else if (subblocks)
14966 current_binding_level->blocks
14967 = chainon (current_binding_level->blocks, subblocks);
14970 TREE_USED (block) = 1;
14975 print_lang_decl (file, node, indent)
14983 print_lang_identifier (file, node, indent)
14988 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14989 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14993 print_lang_statistics ()
14998 print_lang_type (file, node, indent)
15005 /* Record a decl-node X as belonging to the current lexical scope.
15006 Check for errors (such as an incompatible declaration for the same
15007 name already seen in the same scope).
15009 Returns either X or an old decl for the same name.
15010 If an old decl is returned, it may have been smashed
15011 to agree with what X says. */
15018 register tree name = DECL_NAME (x);
15019 register struct binding_level *b = current_binding_level;
15021 if ((TREE_CODE (x) == FUNCTION_DECL)
15022 && (DECL_INITIAL (x) == 0)
15023 && DECL_EXTERNAL (x))
15024 DECL_CONTEXT (x) = NULL_TREE;
15026 DECL_CONTEXT (x) = current_function_decl;
15030 if (IDENTIFIER_INVENTED (name))
15033 DECL_ARTIFICIAL (x) = 1;
15035 DECL_IN_SYSTEM_HEADER (x) = 1;
15038 t = lookup_name_current_level (name);
15040 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15042 /* Don't push non-parms onto list for parms until we understand
15043 why we're doing this and whether it works. */
15045 assert ((b == global_binding_level)
15046 || !ffecom_transform_only_dummies_
15047 || TREE_CODE (x) == PARM_DECL);
15049 if ((t != NULL_TREE) && duplicate_decls (x, t))
15052 /* If we are processing a typedef statement, generate a whole new
15053 ..._TYPE node (which will be just an variant of the existing
15054 ..._TYPE node with identical properties) and then install the
15055 TYPE_DECL node generated to represent the typedef name as the
15056 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15058 The whole point here is to end up with a situation where each and every
15059 ..._TYPE node the compiler creates will be uniquely associated with
15060 AT MOST one node representing a typedef name. This way, even though
15061 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15062 (i.e. "typedef name") nodes very early on, later parts of the
15063 compiler can always do the reverse translation and get back the
15064 corresponding typedef name. For example, given:
15066 typedef struct S MY_TYPE; MY_TYPE object;
15068 Later parts of the compiler might only know that `object' was of type
15069 `struct S' if it were not for code just below. With this code
15070 however, later parts of the compiler see something like:
15072 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15074 And they can then deduce (from the node for type struct S') that the
15075 original object declaration was:
15079 Being able to do this is important for proper support of protoize, and
15080 also for generating precise symbolic debugging information which
15081 takes full account of the programmer's (typedef) vocabulary.
15083 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15084 TYPE_DECL node that we are now processing really represents a
15085 standard built-in type.
15087 Since all standard types are effectively declared at line zero in the
15088 source file, we can easily check to see if we are working on a
15089 standard type by checking the current value of lineno. */
15091 if (TREE_CODE (x) == TYPE_DECL)
15093 if (DECL_SOURCE_LINE (x) == 0)
15095 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15096 TYPE_NAME (TREE_TYPE (x)) = x;
15098 else if (TREE_TYPE (x) != error_mark_node)
15100 tree tt = TREE_TYPE (x);
15102 tt = build_type_copy (tt);
15103 TYPE_NAME (tt) = x;
15104 TREE_TYPE (x) = tt;
15108 /* This name is new in its binding level. Install the new declaration
15110 if (b == global_binding_level)
15111 IDENTIFIER_GLOBAL_VALUE (name) = x;
15113 IDENTIFIER_LOCAL_VALUE (name) = x;
15116 /* Put decls on list in reverse order. We will reverse them later if
15118 TREE_CHAIN (x) = b->names;
15124 /* Nonzero if the current level needs to have a BLOCK made. */
15131 for (decl = current_binding_level->names;
15133 decl = TREE_CHAIN (decl))
15135 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15136 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15137 /* Currently, there aren't supposed to be non-artificial names
15138 at other than the top block for a function -- they're
15139 believed to always be temps. But it's wise to check anyway. */
15145 /* Enter a new binding level.
15146 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15147 not for that of tags. */
15150 pushlevel (tag_transparent)
15151 int tag_transparent;
15153 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15155 assert (! tag_transparent);
15157 if (current_binding_level == global_binding_level)
15162 /* Reuse or create a struct for this binding level. */
15164 if (free_binding_level)
15166 newlevel = free_binding_level;
15167 free_binding_level = free_binding_level->level_chain;
15171 newlevel = make_binding_level ();
15174 /* Add this level to the front of the chain (stack) of levels that
15177 *newlevel = clear_binding_level;
15178 newlevel->level_chain = current_binding_level;
15179 current_binding_level = newlevel;
15182 /* Set the BLOCK node for the innermost scope
15183 (the one we are currently in). */
15187 register tree block;
15189 current_binding_level->this_block = block;
15192 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15194 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15197 set_yydebug (value)
15201 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15205 signed_or_unsigned_type (unsignedp, type)
15211 if (! INTEGRAL_TYPE_P (type))
15213 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15214 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15215 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15216 return unsignedp ? unsigned_type_node : integer_type_node;
15217 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15218 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15219 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15220 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15221 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15222 return (unsignedp ? long_long_unsigned_type_node
15223 : long_long_integer_type_node);
15225 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15226 if (type2 == NULL_TREE)
15236 tree type1 = TYPE_MAIN_VARIANT (type);
15237 ffeinfoKindtype kt;
15240 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15241 return signed_char_type_node;
15242 if (type1 == unsigned_type_node)
15243 return integer_type_node;
15244 if (type1 == short_unsigned_type_node)
15245 return short_integer_type_node;
15246 if (type1 == long_unsigned_type_node)
15247 return long_integer_type_node;
15248 if (type1 == long_long_unsigned_type_node)
15249 return long_long_integer_type_node;
15250 #if 0 /* gcc/c-* files only */
15251 if (type1 == unsigned_intDI_type_node)
15252 return intDI_type_node;
15253 if (type1 == unsigned_intSI_type_node)
15254 return intSI_type_node;
15255 if (type1 == unsigned_intHI_type_node)
15256 return intHI_type_node;
15257 if (type1 == unsigned_intQI_type_node)
15258 return intQI_type_node;
15261 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15262 if (type2 != NULL_TREE)
15265 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15267 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15269 if (type1 == type2)
15270 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15276 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15277 or validate its data type for an `if' or `while' statement or ?..: exp.
15279 This preparation consists of taking the ordinary
15280 representation of an expression expr and producing a valid tree
15281 boolean expression describing whether expr is nonzero. We could
15282 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15283 but we optimize comparisons, &&, ||, and !.
15285 The resulting type should always be `integer_type_node'. */
15288 truthvalue_conversion (expr)
15291 if (TREE_CODE (expr) == ERROR_MARK)
15294 #if 0 /* This appears to be wrong for C++. */
15295 /* These really should return error_mark_node after 2.4 is stable.
15296 But not all callers handle ERROR_MARK properly. */
15297 switch (TREE_CODE (TREE_TYPE (expr)))
15300 error ("struct type value used where scalar is required");
15301 return integer_zero_node;
15304 error ("union type value used where scalar is required");
15305 return integer_zero_node;
15308 error ("array type value used where scalar is required");
15309 return integer_zero_node;
15316 switch (TREE_CODE (expr))
15318 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15319 or comparison expressions as truth values at this level. */
15321 case COMPONENT_REF:
15322 /* A one-bit unsigned bit-field is already acceptable. */
15323 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15324 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15330 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15331 or comparison expressions as truth values at this level. */
15333 if (integer_zerop (TREE_OPERAND (expr, 1)))
15334 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15336 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15337 case TRUTH_ANDIF_EXPR:
15338 case TRUTH_ORIF_EXPR:
15339 case TRUTH_AND_EXPR:
15340 case TRUTH_OR_EXPR:
15341 case TRUTH_XOR_EXPR:
15342 TREE_TYPE (expr) = integer_type_node;
15349 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15352 return real_zerop (expr) ? integer_zero_node : integer_one_node;
15355 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15356 return build (COMPOUND_EXPR, integer_type_node,
15357 TREE_OPERAND (expr, 0), integer_one_node);
15359 return integer_one_node;
15362 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15363 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15365 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15366 truthvalue_conversion (TREE_OPERAND (expr, 1)));
15372 /* These don't change whether an object is non-zero or zero. */
15373 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15377 /* These don't change whether an object is zero or non-zero, but
15378 we can't ignore them if their second arg has side-effects. */
15379 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15380 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15381 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15383 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15386 /* Distribute the conversion into the arms of a COND_EXPR. */
15387 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15388 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15389 truthvalue_conversion (TREE_OPERAND (expr, 2))));
15392 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15393 since that affects how `default_conversion' will behave. */
15394 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15395 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15397 /* fall through... */
15399 /* If this is widening the argument, we can ignore it. */
15400 if (TYPE_PRECISION (TREE_TYPE (expr))
15401 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15402 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15406 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15408 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15409 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15411 /* fall through... */
15413 /* This and MINUS_EXPR can be changed into a comparison of the
15415 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15416 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15417 return ffecom_2 (NE_EXPR, integer_type_node,
15418 TREE_OPERAND (expr, 0),
15419 TREE_OPERAND (expr, 1));
15420 return ffecom_2 (NE_EXPR, integer_type_node,
15421 TREE_OPERAND (expr, 0),
15422 fold (build1 (NOP_EXPR,
15423 TREE_TYPE (TREE_OPERAND (expr, 0)),
15424 TREE_OPERAND (expr, 1))));
15427 if (integer_onep (TREE_OPERAND (expr, 1)))
15432 #if 0 /* No such thing in Fortran. */
15433 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15434 warning ("suggest parentheses around assignment used as truth value");
15442 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15444 ((TREE_SIDE_EFFECTS (expr)
15445 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15447 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15448 TREE_TYPE (TREE_TYPE (expr)),
15450 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15451 TREE_TYPE (TREE_TYPE (expr)),
15454 return ffecom_2 (NE_EXPR, integer_type_node,
15456 convert (TREE_TYPE (expr), integer_zero_node));
15460 type_for_mode (mode, unsignedp)
15461 enum machine_mode mode;
15468 if (mode == TYPE_MODE (integer_type_node))
15469 return unsignedp ? unsigned_type_node : integer_type_node;
15471 if (mode == TYPE_MODE (signed_char_type_node))
15472 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15474 if (mode == TYPE_MODE (short_integer_type_node))
15475 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15477 if (mode == TYPE_MODE (long_integer_type_node))
15478 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15480 if (mode == TYPE_MODE (long_long_integer_type_node))
15481 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15483 #if HOST_BITS_PER_WIDE_INT >= 64
15484 if (mode == TYPE_MODE (intTI_type_node))
15485 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15488 if (mode == TYPE_MODE (float_type_node))
15489 return float_type_node;
15491 if (mode == TYPE_MODE (double_type_node))
15492 return double_type_node;
15494 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15495 return build_pointer_type (char_type_node);
15497 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15498 return build_pointer_type (integer_type_node);
15500 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15501 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15503 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15504 && (mode == TYPE_MODE (t)))
15506 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15507 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15517 type_for_size (bits, unsignedp)
15521 ffeinfoKindtype kt;
15524 if (bits == TYPE_PRECISION (integer_type_node))
15525 return unsignedp ? unsigned_type_node : integer_type_node;
15527 if (bits == TYPE_PRECISION (signed_char_type_node))
15528 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15530 if (bits == TYPE_PRECISION (short_integer_type_node))
15531 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15533 if (bits == TYPE_PRECISION (long_integer_type_node))
15534 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15536 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15537 return (unsignedp ? long_long_unsigned_type_node
15538 : long_long_integer_type_node);
15540 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15542 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15544 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15545 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15553 unsigned_type (type)
15556 tree type1 = TYPE_MAIN_VARIANT (type);
15557 ffeinfoKindtype kt;
15560 if (type1 == signed_char_type_node || type1 == char_type_node)
15561 return unsigned_char_type_node;
15562 if (type1 == integer_type_node)
15563 return unsigned_type_node;
15564 if (type1 == short_integer_type_node)
15565 return short_unsigned_type_node;
15566 if (type1 == long_integer_type_node)
15567 return long_unsigned_type_node;
15568 if (type1 == long_long_integer_type_node)
15569 return long_long_unsigned_type_node;
15570 #if 0 /* gcc/c-* files only */
15571 if (type1 == intDI_type_node)
15572 return unsigned_intDI_type_node;
15573 if (type1 == intSI_type_node)
15574 return unsigned_intSI_type_node;
15575 if (type1 == intHI_type_node)
15576 return unsigned_intHI_type_node;
15577 if (type1 == intQI_type_node)
15578 return unsigned_intQI_type_node;
15581 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15582 if (type2 != NULL_TREE)
15585 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15587 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15589 if (type1 == type2)
15590 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15598 union tree_node *t ATTRIBUTE_UNUSED;
15600 if (TREE_CODE (t) == IDENTIFIER_NODE)
15602 struct lang_identifier *i = (struct lang_identifier *) t;
15603 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15604 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15605 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15607 else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15608 ggc_mark (TYPE_LANG_SPECIFIC (t));
15611 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15613 #if FFECOM_GCC_INCLUDE
15615 /* From gcc/cccp.c, the code to handle -I. */
15617 /* Skip leading "./" from a directory name.
15618 This may yield the empty string, which represents the current directory. */
15620 static const char *
15621 skip_redundant_dir_prefix (const char *dir)
15623 while (dir[0] == '.' && dir[1] == '/')
15624 for (dir += 2; *dir == '/'; dir++)
15626 if (dir[0] == '.' && !dir[1])
15631 /* The file_name_map structure holds a mapping of file names for a
15632 particular directory. This mapping is read from the file named
15633 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15634 map filenames on a file system with severe filename restrictions,
15635 such as DOS. The format of the file name map file is just a series
15636 of lines with two tokens on each line. The first token is the name
15637 to map, and the second token is the actual name to use. */
15639 struct file_name_map
15641 struct file_name_map *map_next;
15646 #define FILE_NAME_MAP_FILE "header.gcc"
15648 /* Current maximum length of directory names in the search path
15649 for include files. (Altered as we get more of them.) */
15651 static int max_include_len = 0;
15653 struct file_name_list
15655 struct file_name_list *next;
15657 /* Mapping of file names for this directory. */
15658 struct file_name_map *name_map;
15659 /* Non-zero if name_map is valid. */
15663 static struct file_name_list *include = NULL; /* First dir to search */
15664 static struct file_name_list *last_include = NULL; /* Last in chain */
15666 /* I/O buffer structure.
15667 The `fname' field is nonzero for source files and #include files
15668 and for the dummy text used for -D and -U.
15669 It is zero for rescanning results of macro expansion
15670 and for expanding macro arguments. */
15671 #define INPUT_STACK_MAX 400
15672 static struct file_buf {
15674 /* Filename specified with #line command. */
15675 const char *nominal_fname;
15676 /* Record where in the search path this file was found.
15677 For #include_next. */
15678 struct file_name_list *dir;
15680 ffewhereColumn column;
15681 } instack[INPUT_STACK_MAX];
15683 static int last_error_tick = 0; /* Incremented each time we print it. */
15684 static int input_file_stack_tick = 0; /* Incremented when status changes. */
15686 /* Current nesting level of input sources.
15687 `instack[indepth]' is the level currently being read. */
15688 static int indepth = -1;
15690 typedef struct file_buf FILE_BUF;
15692 typedef unsigned char U_CHAR;
15694 /* table to tell if char can be part of a C identifier. */
15695 U_CHAR is_idchar[256];
15696 /* table to tell if char can be first char of a c identifier. */
15697 U_CHAR is_idstart[256];
15698 /* table to tell if c is horizontal space. */
15699 U_CHAR is_hor_space[256];
15700 /* table to tell if c is horizontal or vertical space. */
15701 static U_CHAR is_space[256];
15703 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15704 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15706 /* Nonzero means -I- has been seen,
15707 so don't look for #include "foo" the source-file directory. */
15708 static int ignore_srcdir;
15710 #ifndef INCLUDE_LEN_FUDGE
15711 #define INCLUDE_LEN_FUDGE 0
15714 static void append_include_chain (struct file_name_list *first,
15715 struct file_name_list *last);
15716 static FILE *open_include_file (char *filename,
15717 struct file_name_list *searchptr);
15718 static void print_containing_files (ffebadSeverity sev);
15719 static const char *skip_redundant_dir_prefix (const char *);
15720 static char *read_filename_string (int ch, FILE *f);
15721 static struct file_name_map *read_name_map (const char *dirname);
15723 /* Append a chain of `struct file_name_list's
15724 to the end of the main include chain.
15725 FIRST is the beginning of the chain to append, and LAST is the end. */
15728 append_include_chain (first, last)
15729 struct file_name_list *first, *last;
15731 struct file_name_list *dir;
15733 if (!first || !last)
15739 last_include->next = first;
15741 for (dir = first; ; dir = dir->next) {
15742 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15743 if (len > max_include_len)
15744 max_include_len = len;
15750 last_include = last;
15753 /* Try to open include file FILENAME. SEARCHPTR is the directory
15754 being tried from the include file search path. This function maps
15755 filenames on file systems based on information read by
15759 open_include_file (filename, searchptr)
15761 struct file_name_list *searchptr;
15763 register struct file_name_map *map;
15764 register char *from;
15767 if (searchptr && ! searchptr->got_name_map)
15769 searchptr->name_map = read_name_map (searchptr->fname
15770 ? searchptr->fname : ".");
15771 searchptr->got_name_map = 1;
15774 /* First check the mapping for the directory we are using. */
15775 if (searchptr && searchptr->name_map)
15778 if (searchptr->fname)
15779 from += strlen (searchptr->fname) + 1;
15780 for (map = searchptr->name_map; map; map = map->map_next)
15782 if (! strcmp (map->map_from, from))
15784 /* Found a match. */
15785 return fopen (map->map_to, "r");
15790 /* Try to find a mapping file for the particular directory we are
15791 looking in. Thus #include <sys/types.h> will look up sys/types.h
15792 in /usr/include/header.gcc and look up types.h in
15793 /usr/include/sys/header.gcc. */
15794 p = strrchr (filename, '/');
15795 #ifdef DIR_SEPARATOR
15796 if (! p) p = strrchr (filename, DIR_SEPARATOR);
15798 char *tmp = strrchr (filename, DIR_SEPARATOR);
15799 if (tmp != NULL && tmp > p) p = tmp;
15805 && searchptr->fname
15806 && strlen (searchptr->fname) == (size_t) (p - filename)
15807 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15809 /* FILENAME is in SEARCHPTR, which we've already checked. */
15810 return fopen (filename, "r");
15816 map = read_name_map (".");
15820 dir = (char *) xmalloc (p - filename + 1);
15821 memcpy (dir, filename, p - filename);
15822 dir[p - filename] = '\0';
15824 map = read_name_map (dir);
15827 for (; map; map = map->map_next)
15828 if (! strcmp (map->map_from, from))
15829 return fopen (map->map_to, "r");
15831 return fopen (filename, "r");
15834 /* Print the file names and line numbers of the #include
15835 commands which led to the current file. */
15838 print_containing_files (ffebadSeverity sev)
15840 FILE_BUF *ip = NULL;
15846 /* If stack of files hasn't changed since we last printed
15847 this info, don't repeat it. */
15848 if (last_error_tick == input_file_stack_tick)
15851 for (i = indepth; i >= 0; i--)
15852 if (instack[i].fname != NULL) {
15857 /* Give up if we don't find a source file. */
15861 /* Find the other, outer source files. */
15862 for (i--; i >= 0; i--)
15863 if (instack[i].fname != NULL)
15869 str1 = "In file included";
15881 ffebad_start_msg ("%A from %B at %0%C", sev);
15882 ffebad_here (0, ip->line, ip->column);
15883 ffebad_string (str1);
15884 ffebad_string (ip->nominal_fname);
15885 ffebad_string (str2);
15889 /* Record we have printed the status as of this time. */
15890 last_error_tick = input_file_stack_tick;
15893 /* Read a space delimited string of unlimited length from a stdio
15897 read_filename_string (ch, f)
15905 set = alloc = xmalloc (len + 1);
15906 if (! is_space[ch])
15909 while ((ch = getc (f)) != EOF && ! is_space[ch])
15911 if (set - alloc == len)
15914 alloc = xrealloc (alloc, len + 1);
15915 set = alloc + len / 2;
15925 /* Read the file name map file for DIRNAME. */
15927 static struct file_name_map *
15928 read_name_map (dirname)
15929 const char *dirname;
15931 /* This structure holds a linked list of file name maps, one per
15933 struct file_name_map_list
15935 struct file_name_map_list *map_list_next;
15936 char *map_list_name;
15937 struct file_name_map *map_list_map;
15939 static struct file_name_map_list *map_list;
15940 register struct file_name_map_list *map_list_ptr;
15944 int separator_needed;
15946 dirname = skip_redundant_dir_prefix (dirname);
15948 for (map_list_ptr = map_list; map_list_ptr;
15949 map_list_ptr = map_list_ptr->map_list_next)
15950 if (! strcmp (map_list_ptr->map_list_name, dirname))
15951 return map_list_ptr->map_list_map;
15953 map_list_ptr = ((struct file_name_map_list *)
15954 xmalloc (sizeof (struct file_name_map_list)));
15955 map_list_ptr->map_list_name = xstrdup (dirname);
15956 map_list_ptr->map_list_map = NULL;
15958 dirlen = strlen (dirname);
15959 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15960 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15961 strcpy (name, dirname);
15962 name[dirlen] = '/';
15963 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15964 f = fopen (name, "r");
15967 map_list_ptr->map_list_map = NULL;
15972 while ((ch = getc (f)) != EOF)
15975 struct file_name_map *ptr;
15979 from = read_filename_string (ch, f);
15980 while ((ch = getc (f)) != EOF && is_hor_space[ch])
15982 to = read_filename_string (ch, f);
15984 ptr = ((struct file_name_map *)
15985 xmalloc (sizeof (struct file_name_map)));
15986 ptr->map_from = from;
15988 /* Make the real filename absolute. */
15993 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15994 strcpy (ptr->map_to, dirname);
15995 ptr->map_to[dirlen] = '/';
15996 strcpy (ptr->map_to + dirlen + separator_needed, to);
16000 ptr->map_next = map_list_ptr->map_list_map;
16001 map_list_ptr->map_list_map = ptr;
16003 while ((ch = getc (f)) != '\n')
16010 map_list_ptr->map_list_next = map_list;
16011 map_list = map_list_ptr;
16013 return map_list_ptr->map_list_map;
16017 ffecom_file_ (const char *name)
16021 /* Do partial setup of input buffer for the sake of generating
16022 early #line directives (when -g is in effect). */
16024 fp = &instack[++indepth];
16025 memset ((char *) fp, 0, sizeof (FILE_BUF));
16028 fp->nominal_fname = fp->fname = name;
16031 /* Initialize syntactic classifications of characters. */
16034 ffecom_initialize_char_syntax_ ()
16039 * Set up is_idchar and is_idstart tables. These should be
16040 * faster than saying (is_alpha (c) || c == '_'), etc.
16041 * Set up these things before calling any routines tthat
16044 for (i = 'a'; i <= 'z'; i++) {
16045 is_idchar[i - 'a' + 'A'] = 1;
16047 is_idstart[i - 'a' + 'A'] = 1;
16050 for (i = '0'; i <= '9'; i++)
16052 is_idchar['_'] = 1;
16053 is_idstart['_'] = 1;
16055 /* horizontal space table */
16056 is_hor_space[' '] = 1;
16057 is_hor_space['\t'] = 1;
16058 is_hor_space['\v'] = 1;
16059 is_hor_space['\f'] = 1;
16060 is_hor_space['\r'] = 1;
16063 is_space['\t'] = 1;
16064 is_space['\v'] = 1;
16065 is_space['\f'] = 1;
16066 is_space['\n'] = 1;
16067 is_space['\r'] = 1;
16071 ffecom_close_include_ (FILE *f)
16076 input_file_stack_tick++;
16078 ffewhere_line_kill (instack[indepth].line);
16079 ffewhere_column_kill (instack[indepth].column);
16083 ffecom_decode_include_option_ (char *spec)
16085 struct file_name_list *dirtmp;
16087 if (! ignore_srcdir && !strcmp (spec, "-"))
16091 dirtmp = (struct file_name_list *)
16092 xmalloc (sizeof (struct file_name_list));
16093 dirtmp->next = 0; /* New one goes on the end */
16095 dirtmp->fname = spec;
16097 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16098 dirtmp->got_name_map = 0;
16099 append_include_chain (dirtmp, dirtmp);
16104 /* Open INCLUDEd file. */
16107 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16110 size_t flen = strlen (fbeg);
16111 struct file_name_list *search_start = include; /* Chain of dirs to search */
16112 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16113 struct file_name_list *searchptr = 0;
16114 char *fname; /* Dynamically allocated fname buffer */
16121 dsp[0].fname = NULL;
16123 /* If -I- was specified, don't search current dir, only spec'd ones. */
16124 if (!ignore_srcdir)
16126 for (fp = &instack[indepth]; fp >= instack; fp--)
16132 if ((nam = fp->nominal_fname) != NULL)
16134 /* Found a named file. Figure out dir of the file,
16135 and put it in front of the search list. */
16136 dsp[0].next = search_start;
16137 search_start = dsp;
16139 ep = strrchr (nam, '/');
16140 #ifdef DIR_SEPARATOR
16141 if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16143 char *tmp = strrchr (nam, DIR_SEPARATOR);
16144 if (tmp != NULL && tmp > ep) ep = tmp;
16148 ep = strrchr (nam, ']');
16149 if (ep == NULL) ep = strrchr (nam, '>');
16150 if (ep == NULL) ep = strrchr (nam, ':');
16151 if (ep != NULL) ep++;
16156 dsp[0].fname = (char *) xmalloc (n + 1);
16157 strncpy (dsp[0].fname, nam, n);
16158 dsp[0].fname[n] = '\0';
16159 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16160 max_include_len = n + INCLUDE_LEN_FUDGE;
16163 dsp[0].fname = NULL; /* Current directory */
16164 dsp[0].got_name_map = 0;
16170 /* Allocate this permanently, because it gets stored in the definitions
16172 fname = xmalloc (max_include_len + flen + 4);
16173 /* + 2 above for slash and terminating null. */
16174 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16177 /* If specified file name is absolute, just open it. */
16180 #ifdef DIR_SEPARATOR
16181 || *fbeg == DIR_SEPARATOR
16185 strncpy (fname, (char *) fbeg, flen);
16187 f = open_include_file (fname, NULL_PTR);
16193 /* Search directory path, trying to open the file.
16194 Copy each filename tried into FNAME. */
16196 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16198 if (searchptr->fname)
16200 /* The empty string in a search path is ignored.
16201 This makes it possible to turn off entirely
16202 a standard piece of the list. */
16203 if (searchptr->fname[0] == 0)
16205 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16206 if (fname[0] && fname[strlen (fname) - 1] != '/')
16207 strcat (fname, "/");
16208 fname[strlen (fname) + flen] = 0;
16213 strncat (fname, fbeg, flen);
16215 /* Change this 1/2 Unix 1/2 VMS file specification into a
16216 full VMS file specification */
16217 if (searchptr->fname && (searchptr->fname[0] != 0))
16219 /* Fix up the filename */
16220 hack_vms_include_specification (fname);
16224 /* This is a normal VMS filespec, so use it unchanged. */
16225 strncpy (fname, (char *) fbeg, flen);
16227 #if 0 /* Not for g77. */
16228 /* if it's '#include filename', add the missing .h */
16229 if (strchr (fname, '.') == NULL)
16230 strcat (fname, ".h");
16234 f = open_include_file (fname, searchptr);
16236 if (f == NULL && errno == EACCES)
16238 print_containing_files (FFEBAD_severityWARNING);
16239 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16240 FFEBAD_severityWARNING);
16241 ffebad_string (fname);
16242 ffebad_here (0, l, c);
16253 /* A file that was not found. */
16255 strncpy (fname, (char *) fbeg, flen);
16257 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16258 ffebad_start (FFEBAD_OPEN_INCLUDE);
16259 ffebad_here (0, l, c);
16260 ffebad_string (fname);
16264 if (dsp[0].fname != NULL)
16265 free (dsp[0].fname);
16270 if (indepth >= (INPUT_STACK_MAX - 1))
16272 print_containing_files (FFEBAD_severityFATAL);
16273 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16274 FFEBAD_severityFATAL);
16275 ffebad_string (fname);
16276 ffebad_here (0, l, c);
16281 instack[indepth].line = ffewhere_line_use (l);
16282 instack[indepth].column = ffewhere_column_use (c);
16284 fp = &instack[indepth + 1];
16285 memset ((char *) fp, 0, sizeof (FILE_BUF));
16286 fp->nominal_fname = fp->fname = fname;
16287 fp->dir = searchptr;
16290 input_file_stack_tick++;
16294 #endif /* FFECOM_GCC_INCLUDE */
16296 /**INDENT* (Do not reformat this comment even with -fca option.)
16297 Data-gathering files: Given the source file listed below, compiled with
16298 f2c I obtained the output file listed after that, and from the output
16299 file I derived the above code.
16301 -------- (begin input file to f2c)
16307 double precision D1,D2
16309 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16336 c FFEINTRIN_impACOS
16337 call fooR(ACOS(R1))
16338 c FFEINTRIN_impAIMAG
16339 call fooR(AIMAG(C1))
16340 c FFEINTRIN_impAINT
16341 call fooR(AINT(R1))
16342 c FFEINTRIN_impALOG
16343 call fooR(ALOG(R1))
16344 c FFEINTRIN_impALOG10
16345 call fooR(ALOG10(R1))
16346 c FFEINTRIN_impAMAX0
16347 call fooR(AMAX0(I1,I2))
16348 c FFEINTRIN_impAMAX1
16349 call fooR(AMAX1(R1,R2))
16350 c FFEINTRIN_impAMIN0
16351 call fooR(AMIN0(I1,I2))
16352 c FFEINTRIN_impAMIN1
16353 call fooR(AMIN1(R1,R2))
16354 c FFEINTRIN_impAMOD
16355 call fooR(AMOD(R1,R2))
16356 c FFEINTRIN_impANINT
16357 call fooR(ANINT(R1))
16358 c FFEINTRIN_impASIN
16359 call fooR(ASIN(R1))
16360 c FFEINTRIN_impATAN
16361 call fooR(ATAN(R1))
16362 c FFEINTRIN_impATAN2
16363 call fooR(ATAN2(R1,R2))
16364 c FFEINTRIN_impCABS
16365 call fooR(CABS(C1))
16366 c FFEINTRIN_impCCOS
16367 call fooC(CCOS(C1))
16368 c FFEINTRIN_impCEXP
16369 call fooC(CEXP(C1))
16370 c FFEINTRIN_impCHAR
16371 call fooA(CHAR(I1))
16372 c FFEINTRIN_impCLOG
16373 call fooC(CLOG(C1))
16374 c FFEINTRIN_impCONJG
16375 call fooC(CONJG(C1))
16378 c FFEINTRIN_impCOSH
16379 call fooR(COSH(R1))
16380 c FFEINTRIN_impCSIN
16381 call fooC(CSIN(C1))
16382 c FFEINTRIN_impCSQRT
16383 call fooC(CSQRT(C1))
16384 c FFEINTRIN_impDABS
16385 call fooD(DABS(D1))
16386 c FFEINTRIN_impDACOS
16387 call fooD(DACOS(D1))
16388 c FFEINTRIN_impDASIN
16389 call fooD(DASIN(D1))
16390 c FFEINTRIN_impDATAN
16391 call fooD(DATAN(D1))
16392 c FFEINTRIN_impDATAN2
16393 call fooD(DATAN2(D1,D2))
16394 c FFEINTRIN_impDCOS
16395 call fooD(DCOS(D1))
16396 c FFEINTRIN_impDCOSH
16397 call fooD(DCOSH(D1))
16398 c FFEINTRIN_impDDIM
16399 call fooD(DDIM(D1,D2))
16400 c FFEINTRIN_impDEXP
16401 call fooD(DEXP(D1))
16403 call fooR(DIM(R1,R2))
16404 c FFEINTRIN_impDINT
16405 call fooD(DINT(D1))
16406 c FFEINTRIN_impDLOG
16407 call fooD(DLOG(D1))
16408 c FFEINTRIN_impDLOG10
16409 call fooD(DLOG10(D1))
16410 c FFEINTRIN_impDMAX1
16411 call fooD(DMAX1(D1,D2))
16412 c FFEINTRIN_impDMIN1
16413 call fooD(DMIN1(D1,D2))
16414 c FFEINTRIN_impDMOD
16415 call fooD(DMOD(D1,D2))
16416 c FFEINTRIN_impDNINT
16417 call fooD(DNINT(D1))
16418 c FFEINTRIN_impDPROD
16419 call fooD(DPROD(R1,R2))
16420 c FFEINTRIN_impDSIGN
16421 call fooD(DSIGN(D1,D2))
16422 c FFEINTRIN_impDSIN
16423 call fooD(DSIN(D1))
16424 c FFEINTRIN_impDSINH
16425 call fooD(DSINH(D1))
16426 c FFEINTRIN_impDSQRT
16427 call fooD(DSQRT(D1))
16428 c FFEINTRIN_impDTAN
16429 call fooD(DTAN(D1))
16430 c FFEINTRIN_impDTANH
16431 call fooD(DTANH(D1))
16434 c FFEINTRIN_impIABS
16435 call fooI(IABS(I1))
16436 c FFEINTRIN_impICHAR
16437 call fooI(ICHAR(A1))
16438 c FFEINTRIN_impIDIM
16439 call fooI(IDIM(I1,I2))
16440 c FFEINTRIN_impIDNINT
16441 call fooI(IDNINT(D1))
16442 c FFEINTRIN_impINDEX
16443 call fooI(INDEX(A1,A2))
16444 c FFEINTRIN_impISIGN
16445 call fooI(ISIGN(I1,I2))
16449 call fooL(LGE(A1,A2))
16451 call fooL(LGT(A1,A2))
16453 call fooL(LLE(A1,A2))
16455 call fooL(LLT(A1,A2))
16456 c FFEINTRIN_impMAX0
16457 call fooI(MAX0(I1,I2))
16458 c FFEINTRIN_impMAX1
16459 call fooI(MAX1(R1,R2))
16460 c FFEINTRIN_impMIN0
16461 call fooI(MIN0(I1,I2))
16462 c FFEINTRIN_impMIN1
16463 call fooI(MIN1(R1,R2))
16465 call fooI(MOD(I1,I2))
16466 c FFEINTRIN_impNINT
16467 call fooI(NINT(R1))
16468 c FFEINTRIN_impSIGN
16469 call fooR(SIGN(R1,R2))
16472 c FFEINTRIN_impSINH
16473 call fooR(SINH(R1))
16474 c FFEINTRIN_impSQRT
16475 call fooR(SQRT(R1))
16478 c FFEINTRIN_impTANH
16479 call fooR(TANH(R1))
16480 c FFEINTRIN_imp_CMPLX_C
16481 call fooC(cmplx(C1,C2))
16482 c FFEINTRIN_imp_CMPLX_D
16483 call fooZ(cmplx(D1,D2))
16484 c FFEINTRIN_imp_CMPLX_I
16485 call fooC(cmplx(I1,I2))
16486 c FFEINTRIN_imp_CMPLX_R
16487 call fooC(cmplx(R1,R2))
16488 c FFEINTRIN_imp_DBLE_C
16489 call fooD(dble(C1))
16490 c FFEINTRIN_imp_DBLE_D
16491 call fooD(dble(D1))
16492 c FFEINTRIN_imp_DBLE_I
16493 call fooD(dble(I1))
16494 c FFEINTRIN_imp_DBLE_R
16495 call fooD(dble(R1))
16496 c FFEINTRIN_imp_INT_C
16498 c FFEINTRIN_imp_INT_D
16500 c FFEINTRIN_imp_INT_I
16502 c FFEINTRIN_imp_INT_R
16504 c FFEINTRIN_imp_REAL_C
16505 call fooR(real(C1))
16506 c FFEINTRIN_imp_REAL_D
16507 call fooR(real(D1))
16508 c FFEINTRIN_imp_REAL_I
16509 call fooR(real(I1))
16510 c FFEINTRIN_imp_REAL_R
16511 call fooR(real(R1))
16513 c FFEINTRIN_imp_INT_D:
16515 c FFEINTRIN_specIDINT
16516 call fooI(IDINT(D1))
16518 c FFEINTRIN_imp_INT_R:
16520 c FFEINTRIN_specIFIX
16521 call fooI(IFIX(R1))
16522 c FFEINTRIN_specINT
16525 c FFEINTRIN_imp_REAL_D:
16527 c FFEINTRIN_specSNGL
16528 call fooR(SNGL(D1))
16530 c FFEINTRIN_imp_REAL_I:
16532 c FFEINTRIN_specFLOAT
16533 call fooR(FLOAT(I1))
16534 c FFEINTRIN_specREAL
16535 call fooR(REAL(I1))
16538 -------- (end input file to f2c)
16540 -------- (begin output from providing above input file as input to:
16541 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16542 -------- -e "s:^#.*$::g"')
16544 // -- translated by f2c (version 19950223).
16545 You must link the resulting object file with the libraries:
16546 -lf2c -lm (in that order)
16550 // f2c.h -- Standard Fortran to C header file //
16552 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16554 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16559 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16560 // we assume short, float are OK //
16561 typedef long int // long int // integer;
16562 typedef char *address;
16563 typedef short int shortint;
16564 typedef float real;
16565 typedef double doublereal;
16566 typedef struct { real r, i; } complex;
16567 typedef struct { doublereal r, i; } doublecomplex;
16568 typedef long int // long int // logical;
16569 typedef short int shortlogical;
16570 typedef char logical1;
16571 typedef char integer1;
16572 // typedef long long longint; // // system-dependent //
16577 // Extern is for use with -E //
16591 typedef long int // int or long int // flag;
16592 typedef long int // int or long int // ftnlen;
16593 typedef long int // int or long int // ftnint;
16596 //external read, write//
16605 //internal read, write//
16635 //rewind, backspace, endfile//
16647 ftnint *inex; //parameters in standard's order//
16673 union Multitype { // for multiple entry points //
16684 typedef union Multitype Multitype;
16686 typedef long Long; // No longer used; formerly in Namelist //
16688 struct Vardesc { // for Namelist //
16694 typedef struct Vardesc Vardesc;
16701 typedef struct Namelist Namelist;
16710 // procedure parameter types for -A and -C++ //
16715 typedef int // Unknown procedure type // (*U_fp)();
16716 typedef shortint (*J_fp)();
16717 typedef integer (*I_fp)();
16718 typedef real (*R_fp)();
16719 typedef doublereal (*D_fp)(), (*E_fp)();
16720 typedef // Complex // void (*C_fp)();
16721 typedef // Double Complex // void (*Z_fp)();
16722 typedef logical (*L_fp)();
16723 typedef shortlogical (*K_fp)();
16724 typedef // Character // void (*H_fp)();
16725 typedef // Subroutine // int (*S_fp)();
16727 // E_fp is for real functions when -R is not specified //
16728 typedef void C_f; // complex function //
16729 typedef void H_f; // character function //
16730 typedef void Z_f; // double complex function //
16731 typedef doublereal E_f; // real function with -R not specified //
16733 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16736 // (No such symbols should be defined in a strict ANSI C compiler.
16737 We can avoid trouble with f2c-translated code by using
16738 gcc -ansi [-traditional].) //
16762 // Main program // MAIN__()
16764 // System generated locals //
16767 doublereal d__1, d__2;
16769 doublecomplex z__1, z__2, z__3;
16773 // Builtin functions //
16776 double pow_ri(), pow_di();
16780 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16781 asin(), atan(), atan2(), c_abs();
16782 void c_cos(), c_exp(), c_log(), r_cnjg();
16783 double cos(), cosh();
16784 void c_sin(), c_sqrt();
16785 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16786 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16787 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16788 logical l_ge(), l_gt(), l_le(), l_lt();
16792 // Local variables //
16793 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16794 fool_(), fooz_(), getem_();
16795 static char a1[10], a2[10];
16796 static complex c1, c2;
16797 static doublereal d1, d2;
16798 static integer i1, i2;
16799 static real r1, r2;
16802 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16810 d__1 = (doublereal) i1;
16811 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16821 c_div(&q__1, &c1, &c2);
16823 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16825 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16828 i__1 = pow_ii(&i1, &i2);
16830 r__1 = pow_ri(&r1, &i1);
16832 d__1 = pow_di(&d1, &i1);
16834 pow_ci(&q__1, &c1, &i1);
16836 d__1 = (doublereal) r1;
16837 d__2 = (doublereal) r2;
16838 r__1 = pow_dd(&d__1, &d__2);
16840 d__2 = (doublereal) r1;
16841 d__1 = pow_dd(&d__2, &d1);
16843 d__1 = pow_dd(&d1, &d2);
16845 d__2 = (doublereal) r1;
16846 d__1 = pow_dd(&d1, &d__2);
16848 z__2.r = c1.r, z__2.i = c1.i;
16849 z__3.r = c2.r, z__3.i = c2.i;
16850 pow_zz(&z__1, &z__2, &z__3);
16851 q__1.r = z__1.r, q__1.i = z__1.i;
16853 z__2.r = c1.r, z__2.i = c1.i;
16854 z__3.r = r1, z__3.i = 0.;
16855 pow_zz(&z__1, &z__2, &z__3);
16856 q__1.r = z__1.r, q__1.i = z__1.i;
16858 z__2.r = c1.r, z__2.i = c1.i;
16859 z__3.r = d1, z__3.i = 0.;
16860 pow_zz(&z__1, &z__2, &z__3);
16862 // FFEINTRIN_impABS //
16863 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16865 // FFEINTRIN_impACOS //
16868 // FFEINTRIN_impAIMAG //
16869 r__1 = r_imag(&c1);
16871 // FFEINTRIN_impAINT //
16874 // FFEINTRIN_impALOG //
16877 // FFEINTRIN_impALOG10 //
16878 r__1 = r_lg10(&r1);
16880 // FFEINTRIN_impAMAX0 //
16881 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16883 // FFEINTRIN_impAMAX1 //
16884 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16886 // FFEINTRIN_impAMIN0 //
16887 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16889 // FFEINTRIN_impAMIN1 //
16890 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16892 // FFEINTRIN_impAMOD //
16893 r__1 = r_mod(&r1, &r2);
16895 // FFEINTRIN_impANINT //
16896 r__1 = r_nint(&r1);
16898 // FFEINTRIN_impASIN //
16901 // FFEINTRIN_impATAN //
16904 // FFEINTRIN_impATAN2 //
16905 r__1 = atan2(r1, r2);
16907 // FFEINTRIN_impCABS //
16910 // FFEINTRIN_impCCOS //
16913 // FFEINTRIN_impCEXP //
16916 // FFEINTRIN_impCHAR //
16917 *(unsigned char *)&ch__1[0] = i1;
16919 // FFEINTRIN_impCLOG //
16922 // FFEINTRIN_impCONJG //
16923 r_cnjg(&q__1, &c1);
16925 // FFEINTRIN_impCOS //
16928 // FFEINTRIN_impCOSH //
16931 // FFEINTRIN_impCSIN //
16934 // FFEINTRIN_impCSQRT //
16935 c_sqrt(&q__1, &c1);
16937 // FFEINTRIN_impDABS //
16938 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16940 // FFEINTRIN_impDACOS //
16943 // FFEINTRIN_impDASIN //
16946 // FFEINTRIN_impDATAN //
16949 // FFEINTRIN_impDATAN2 //
16950 d__1 = atan2(d1, d2);
16952 // FFEINTRIN_impDCOS //
16955 // FFEINTRIN_impDCOSH //
16958 // FFEINTRIN_impDDIM //
16959 d__1 = d_dim(&d1, &d2);
16961 // FFEINTRIN_impDEXP //
16964 // FFEINTRIN_impDIM //
16965 r__1 = r_dim(&r1, &r2);
16967 // FFEINTRIN_impDINT //
16970 // FFEINTRIN_impDLOG //
16973 // FFEINTRIN_impDLOG10 //
16974 d__1 = d_lg10(&d1);
16976 // FFEINTRIN_impDMAX1 //
16977 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16979 // FFEINTRIN_impDMIN1 //
16980 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16982 // FFEINTRIN_impDMOD //
16983 d__1 = d_mod(&d1, &d2);
16985 // FFEINTRIN_impDNINT //
16986 d__1 = d_nint(&d1);
16988 // FFEINTRIN_impDPROD //
16989 d__1 = (doublereal) r1 * r2;
16991 // FFEINTRIN_impDSIGN //
16992 d__1 = d_sign(&d1, &d2);
16994 // FFEINTRIN_impDSIN //
16997 // FFEINTRIN_impDSINH //
17000 // FFEINTRIN_impDSQRT //
17003 // FFEINTRIN_impDTAN //
17006 // FFEINTRIN_impDTANH //
17009 // FFEINTRIN_impEXP //
17012 // FFEINTRIN_impIABS //
17013 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17015 // FFEINTRIN_impICHAR //
17016 i__1 = *(unsigned char *)a1;
17018 // FFEINTRIN_impIDIM //
17019 i__1 = i_dim(&i1, &i2);
17021 // FFEINTRIN_impIDNINT //
17022 i__1 = i_dnnt(&d1);
17024 // FFEINTRIN_impINDEX //
17025 i__1 = i_indx(a1, a2, 10L, 10L);
17027 // FFEINTRIN_impISIGN //
17028 i__1 = i_sign(&i1, &i2);
17030 // FFEINTRIN_impLEN //
17031 i__1 = i_len(a1, 10L);
17033 // FFEINTRIN_impLGE //
17034 L__1 = l_ge(a1, a2, 10L, 10L);
17036 // FFEINTRIN_impLGT //
17037 L__1 = l_gt(a1, a2, 10L, 10L);
17039 // FFEINTRIN_impLLE //
17040 L__1 = l_le(a1, a2, 10L, 10L);
17042 // FFEINTRIN_impLLT //
17043 L__1 = l_lt(a1, a2, 10L, 10L);
17045 // FFEINTRIN_impMAX0 //
17046 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17048 // FFEINTRIN_impMAX1 //
17049 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17051 // FFEINTRIN_impMIN0 //
17052 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17054 // FFEINTRIN_impMIN1 //
17055 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17057 // FFEINTRIN_impMOD //
17060 // FFEINTRIN_impNINT //
17061 i__1 = i_nint(&r1);
17063 // FFEINTRIN_impSIGN //
17064 r__1 = r_sign(&r1, &r2);
17066 // FFEINTRIN_impSIN //
17069 // FFEINTRIN_impSINH //
17072 // FFEINTRIN_impSQRT //
17075 // FFEINTRIN_impTAN //
17078 // FFEINTRIN_impTANH //
17081 // FFEINTRIN_imp_CMPLX_C //
17084 q__1.r = r__1, q__1.i = r__2;
17086 // FFEINTRIN_imp_CMPLX_D //
17087 z__1.r = d1, z__1.i = d2;
17089 // FFEINTRIN_imp_CMPLX_I //
17092 q__1.r = r__1, q__1.i = r__2;
17094 // FFEINTRIN_imp_CMPLX_R //
17095 q__1.r = r1, q__1.i = r2;
17097 // FFEINTRIN_imp_DBLE_C //
17098 d__1 = (doublereal) c1.r;
17100 // FFEINTRIN_imp_DBLE_D //
17103 // FFEINTRIN_imp_DBLE_I //
17104 d__1 = (doublereal) i1;
17106 // FFEINTRIN_imp_DBLE_R //
17107 d__1 = (doublereal) r1;
17109 // FFEINTRIN_imp_INT_C //
17110 i__1 = (integer) c1.r;
17112 // FFEINTRIN_imp_INT_D //
17113 i__1 = (integer) d1;
17115 // FFEINTRIN_imp_INT_I //
17118 // FFEINTRIN_imp_INT_R //
17119 i__1 = (integer) r1;
17121 // FFEINTRIN_imp_REAL_C //
17124 // FFEINTRIN_imp_REAL_D //
17127 // FFEINTRIN_imp_REAL_I //
17130 // FFEINTRIN_imp_REAL_R //
17134 // FFEINTRIN_imp_INT_D: //
17136 // FFEINTRIN_specIDINT //
17137 i__1 = (integer) d1;
17140 // FFEINTRIN_imp_INT_R: //
17142 // FFEINTRIN_specIFIX //
17143 i__1 = (integer) r1;
17145 // FFEINTRIN_specINT //
17146 i__1 = (integer) r1;
17149 // FFEINTRIN_imp_REAL_D: //
17151 // FFEINTRIN_specSNGL //
17155 // FFEINTRIN_imp_REAL_I: //
17157 // FFEINTRIN_specFLOAT //
17160 // FFEINTRIN_specREAL //
17166 -------- (end output file from f2c)