diff options
Diffstat (limited to 'gcc/f/com.c')
| -rw-r--r-- | gcc/f/com.c | 16225 |
1 files changed, 16225 insertions, 0 deletions
diff --git a/gcc/f/com.c b/gcc/f/com.c new file mode 100644 index 00000000000..65a6ea9c282 --- /dev/null +++ b/gcc/f/com.c @@ -0,0 +1,16225 @@ +/* com.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Contains compiler-specific functions. + + Modifications: +*/ + +/* Understanding this module means understanding the interface between + the g77 front end and the gcc back end (or, perhaps, some other + back end). In here are the functions called by the front end proper + to notify whatever back end is in place about certain things, and + also the back-end-specific functions. It's a bear to deal with, so + lately I've been trying to simplify things, especially with regard + to the gcc-back-end-specific stuff. + + Building expressions generally seems quite easy, but building decls + has been challenging and is undergoing revision. gcc has several + kinds of decls: + + TYPE_DECL -- a type (int, float, struct, function, etc.) + CONST_DECL -- a constant of some type other than function + LABEL_DECL -- a variable or a constant? + PARM_DECL -- an argument to a function (a variable that is a dummy) + RESULT_DECL -- the return value of a function (a variable) + VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.) + FUNCTION_DECL -- a function (either the actual function or an extern ref) + FIELD_DECL -- a field in a struct or union (goes into types) + + g77 has a set of functions that somewhat parallels the gcc front end + when it comes to building decls: + + Internal Function (one we define, not just declare as extern): + int yes; + yes = suspend_momentary (); + if (is_nested) push_f_function_context (); + start_function (get_identifier ("function_name"), function_type, + is_nested, is_public); + // for each arg, build PARM_DECL and call push_parm_decl (decl) with it; + store_parm_decls (is_main_program); + ffecom_start_compstmt_ (); + // for stmts and decls inside function, do appropriate things; + ffecom_end_compstmt_ (); + finish_function (is_nested); + if (is_nested) pop_f_function_context (); + if (is_nested) resume_momentary (yes); + + Everything Else: + int yes; + tree d; + tree init; + yes = suspend_momentary (); + // fill in external, public, static, &c for decl, and + // set DECL_INITIAL to error_mark_node if going to initialize + // set is_top_level TRUE only if not at top level and decl + // must go in top level (i.e. not within current function decl context) + d = start_decl (decl, is_top_level); + init = ...; // if have initializer + finish_decl (d, init, is_top_level); + resume_momentary (yes); + +*/ + +/* Include files. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#include "config.j" +#include "flags.j" +#include "rtl.j" +#include "tree.j" +#include "convert.j" +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */ + +/* BEGIN stuff from gcc/cccp.c. */ + +/* The following symbols should be autoconfigured: + HAVE_FCNTL_H + HAVE_STDLIB_H + HAVE_SYS_TIME_H + HAVE_UNISTD_H + STDC_HEADERS + TIME_WITH_SYS_TIME + In the mean time, we'll get by with approximations based + on existing GCC configuration symbols. */ + +#ifdef POSIX +# ifndef HAVE_STDLIB_H +# define HAVE_STDLIB_H 1 +# endif +# ifndef HAVE_UNISTD_H +# define HAVE_UNISTD_H 1 +# endif +# ifndef STDC_HEADERS +# define STDC_HEADERS 1 +# endif +#endif /* defined (POSIX) */ + +#if defined (POSIX) || (defined (USG) && !defined (VMS)) +# ifndef HAVE_FCNTL_H +# define HAVE_FCNTL_H 1 +# endif +#endif + +#ifndef RLIMIT_STACK +# include <time.h> +#else +# if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +# else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +# endif +# include <sys/resource.h> +#endif + +#if HAVE_FCNTL_H +# include <fcntl.h> +#endif + +/* This defines "errno" properly for VMS, and gives us EACCES. */ +#include <errno.h> + +#if HAVE_STDLIB_H +# include <stdlib.h> +#else +char *getenv (); +#endif + +char *index (); +char *rindex (); + +#if HAVE_UNISTD_H +# include <unistd.h> +#endif + +/* VMS-specific definitions */ +#ifdef VMS +#include <descrip.h> +#define O_RDONLY 0 /* Open arg for Read/Only */ +#define O_WRONLY 1 /* Open arg for Write/Only */ +#define read(fd,buf,size) VMS_read (fd,buf,size) +#define write(fd,buf,size) VMS_write (fd,buf,size) +#define open(fname,mode,prot) VMS_open (fname,mode,prot) +#define fopen(fname,mode) VMS_fopen (fname,mode) +#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile) +#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt) +#define fstat(fd,stbuf) VMS_fstat (fd,stbuf) +static int VMS_fstat (), VMS_stat (); +static char * VMS_strncat (); +static int VMS_read (); +static int VMS_write (); +static int VMS_open (); +static FILE * VMS_fopen (); +static FILE * VMS_freopen (); +static void hack_vms_include_specification (); +typedef struct { unsigned :16, :16, :16; } vms_ino_t; +#define ino_t vms_ino_t +#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */ +#ifdef __GNUC__ +#define BSTRING /* VMS/GCC supplies the bstring routines */ +#endif /* __GNUC__ */ +#endif /* VMS */ + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif + +/* END stuff from gcc/cccp.c. */ + +#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 /* for com.h */ +#include "com.h" +#include "bad.h" +#include "bld.h" +#include "equiv.h" +#include "expr.h" +#include "implic.h" +#include "info.h" +#include "malloc.h" +#include "src.h" +#include "st.h" +#include "storag.h" +#include "symbol.h" +#include "target.h" +#include "top.h" +#include "type.h" + +/* Externals defined here. */ + +#define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + +/* tree.h declares a bunch of stuff that it expects the front end to + define. Here are the definitions, which in the C front end are + found in the file c-decl.c. */ + +tree integer_zero_node; +tree integer_one_node; +tree null_pointer_node; +tree error_mark_node; +tree void_type_node; +tree integer_type_node; +tree unsigned_type_node; +tree char_type_node; +tree current_function_decl; + +/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference + it. */ + +char *language_string = "GNU F77"; + +/* These definitions parallel those in c-decl.c so that code from that + module can be used pretty much as is. Much of these defs aren't + otherwise used, i.e. by g77 code per se, except some of them are used + to build some of them that are. The ones that are global (i.e. not + "static") are those that ste.c and such might use (directly + or by using com macros that reference them in their definitions). */ + +static tree short_integer_type_node; +tree long_integer_type_node; +static tree long_long_integer_type_node; + +static tree short_unsigned_type_node; +static tree long_unsigned_type_node; +static tree long_long_unsigned_type_node; + +static tree unsigned_char_type_node; +static tree signed_char_type_node; + +static tree float_type_node; +static tree double_type_node; +static tree complex_float_type_node; +tree complex_double_type_node; +static tree long_double_type_node; +static tree complex_integer_type_node; +static tree complex_long_double_type_node; + +tree string_type_node; + +static tree double_ftype_double; +static tree float_ftype_float; +static tree ldouble_ftype_ldouble; + +/* The rest of these are inventions for g77, though there might be + similar things in the C front end. As they are found, these + inventions should be renamed to be canonical. Note that only + the ones currently required to be global are so. */ + +static tree ffecom_tree_fun_type_void; +static tree ffecom_tree_ptr_to_fun_type_void; + +tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */ +tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */ +tree ffecom_integer_one_node; /* " */ +tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype]; + +/* _fun_type things are the f2c-specific versions. For -fno-f2c, + just use build_function_type and build_pointer_type on the + appropriate _tree_type array element. */ + +static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; +static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; +static tree ffecom_tree_subr_type; +static tree ffecom_tree_ptr_to_subr_type; +static tree ffecom_tree_blockdata_type; + +static tree ffecom_tree_xargc_; + +ffecomSymbol ffecom_symbol_null_ += +{ + NULL_TREE, + NULL_TREE, + NULL_TREE, +}; +ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE; +ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE; + +int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype]; +tree ffecom_f2c_integer_type_node; +tree ffecom_f2c_ptr_to_integer_type_node; +tree ffecom_f2c_address_type_node; +tree ffecom_f2c_real_type_node; +tree ffecom_f2c_ptr_to_real_type_node; +tree ffecom_f2c_doublereal_type_node; +tree ffecom_f2c_complex_type_node; +tree ffecom_f2c_doublecomplex_type_node; +tree ffecom_f2c_longint_type_node; +tree ffecom_f2c_logical_type_node; +tree ffecom_f2c_flag_type_node; +tree ffecom_f2c_ftnlen_type_node; +tree ffecom_f2c_ftnlen_zero_node; +tree ffecom_f2c_ftnlen_one_node; +tree ffecom_f2c_ftnlen_two_node; +tree ffecom_f2c_ptr_to_ftnlen_type_node; +tree ffecom_f2c_ftnint_type_node; +tree ffecom_f2c_ptr_to_ftnint_type_node; +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Simple definitions and enumerations. */ + +#ifndef FFECOM_sizeMAXSTACKITEM +#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things + larger than this # bytes + off stack if possible. */ +#endif + +/* For systems that have large enough stacks, they should define + this to 0, and here, for ease of use later on, we just undefine + it if it is 0. */ + +#if FFECOM_sizeMAXSTACKITEM == 0 +#undef FFECOM_sizeMAXSTACKITEM +#endif + +typedef enum + { + FFECOM_rttypeVOID_, + FFECOM_rttypeINT_, /* C's `int' type, for libF77/system_.c? */ + FFECOM_rttypeINTEGER_, + FFECOM_rttypeLONGINT_, /* C's `long long int' type. */ + FFECOM_rttypeLOGICAL_, + FFECOM_rttypeREAL_F2C_, /* f2c's `float' returned as `double'. */ + FFECOM_rttypeREAL_GNU_, /* `float' returned as such. */ + FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */ + FFECOM_rttypeCOMPLEX_GNU_, /* gcc's `complex float' returned as such. */ + FFECOM_rttypeDOUBLE_, /* C's `double' type. */ + FFECOM_rttypeDOUBLEREAL_, + FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */ + FFECOM_rttypeDBLCMPLX_GNU_, /* gcc's `complex double' returned as such. */ + FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */ + FFECOM_rttype_ + } ffecomRttype_; + +/* Internal typedefs. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +typedef struct _ffecom_concat_list_ ffecomConcatList_; +typedef struct _ffecom_temp_ *ffecomTemp_; +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Private include files. */ + + +/* Internal structure definitions. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +struct _ffecom_concat_list_ + { + ffebld *exprs; + int count; + int max; + ffetargetCharacterSize minlen; + ffetargetCharacterSize maxlen; + }; + +struct _ffecom_temp_ + { + ffecomTemp_ next; + tree type; /* Base type (w/o size/array applied). */ + tree t; + ffetargetCharacterSize size; + int elements; + bool in_use; + bool auto_pop; + }; + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Static functions (internal). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree ffecom_arglist_expr_ (char *argstring, ffebld args); +static tree ffecom_widest_expr_type_ (ffebld list); +static bool ffecom_overlap_ (tree dest_decl, tree dest_offset, + tree dest_size, tree source_tree, + ffebld source, bool scalar_arg); +static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest, + tree args, tree callee_commons, + bool scalar_args); +static tree ffecom_build_f2c_string_ (int i, char *s); +static tree ffecom_call_ (tree fn, ffeinfoKindtype kt, + bool is_f2c_complex, tree type, + tree args, tree dest_tree, + ffebld dest, bool *dest_used, + tree callee_commons, bool scalar_args); +static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, + bool is_f2c_complex, tree type, + ffebld left, ffebld right, + tree dest_tree, ffebld dest, + bool *dest_used, tree callee_commons, + bool scalar_args); +static void ffecom_char_args_ (tree *xitem, tree *length, + ffebld expr); +static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy); +static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s); +static ffecomConcatList_ + ffecom_concat_list_gather_ (ffecomConcatList_ catlist, + ffebld expr, + ffetargetCharacterSize max); +static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist); +static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr, + ffetargetCharacterSize max); +static void ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member, + tree member_type, ffetargetOffset offset); +static void ffecom_do_entry_ (ffesymbol fn, int entrynum); +static tree ffecom_expr_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used, + bool assignp); +static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used); +static tree ffecom_expr_power_integer_ (ffebld left, ffebld right); +static void ffecom_expr_transform_ (ffebld expr); +static void ffecom_f2c_make_type_ (tree *type, int tcode, char *name); +static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, + int code); +static ffeglobal ffecom_finish_global_ (ffeglobal global); +static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s); +static tree ffecom_get_appended_identifier_ (char us, char *text); +static tree ffecom_get_external_identifier_ (ffesymbol s); +static tree ffecom_get_identifier_ (char *text); +static tree ffecom_gen_sfuncdef_ (ffesymbol s, + ffeinfoBasictype bt, + ffeinfoKindtype kt); +static char *ffecom_gfrt_args_ (ffecomGfrt ix); +static tree ffecom_gfrt_tree_ (ffecomGfrt ix); +static tree ffecom_init_zero_ (tree decl); +static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, + tree *maybe_tree); +static tree ffecom_intrinsic_len_ (ffebld expr); +static void ffecom_let_char_ (tree dest_tree, + tree dest_length, + ffetargetCharacterSize dest_size, + ffebld source); +static void ffecom_make_gfrt_ (ffecomGfrt ix); +static void ffecom_member_phase1_ (ffestorag mst, ffestorag st); +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING +static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); +#endif +static void ffecom_push_dummy_decls_ (ffebld dumlist, + bool stmtfunc); +static void ffecom_start_progunit_ (void); +static ffesymbol ffecom_sym_transform_ (ffesymbol s); +static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s); +static void ffecom_transform_common_ (ffesymbol s); +static void ffecom_transform_equiv_ (ffestorag st); +static tree ffecom_transform_namelist_ (ffesymbol s); +static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, + tree t); +static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset, + tree *size, tree tree); +static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right, + tree dest_tree, ffebld dest, + bool *dest_used); +static tree ffecom_type_localvar_ (ffesymbol s, + ffeinfoBasictype bt, + ffeinfoKindtype kt); +static tree ffecom_type_namelist_ (void); +#if 0 +static tree ffecom_type_permanent_copy_ (tree t); +#endif +static tree ffecom_type_vardesc_ (void); +static tree ffecom_vardesc_ (ffebld expr); +static tree ffecom_vardesc_array_ (ffesymbol s); +static tree ffecom_vardesc_dims_ (ffesymbol s); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* These are static functions that parallel those found in the C front + end and thus have the same names. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void bison_rule_compstmt_ (void); +static void bison_rule_pushlevel_ (void); +static tree builtin_function (char *name, tree type, + enum built_in_function function_code, + char *library_name); +static int duplicate_decls (tree newdecl, tree olddecl); +static void finish_decl (tree decl, tree init, bool is_top_level); +static void finish_function (int nested); +static char *lang_printable_name (tree decl, char **kind); +static tree lookup_name_current_level (tree name); +static struct binding_level *make_binding_level (void); +static void pop_f_function_context (void); +static void push_f_function_context (void); +static void push_parm_decl (tree parm); +static tree pushdecl_top_level (tree decl); +static tree storedecls (tree decls); +static void store_parm_decls (int is_main_program); +static tree start_decl (tree decl, bool is_top_level); +static void start_function (tree name, tree type, int nested, int public); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ +#if FFECOM_GCC_INCLUDE +static void ffecom_file_ (char *name); +static void ffecom_initialize_char_syntax_ (void); +static void ffecom_close_include_ (FILE *f); +static int ffecom_decode_include_option_ (char *spec); +static FILE *ffecom_open_include_ (char *name, ffewhereLine l, + ffewhereColumn c); +#endif /* FFECOM_GCC_INCLUDE */ + +/* Static objects accessed by functions in this module. */ + +static ffesymbol ffecom_primary_entry_ = NULL; +static ffesymbol ffecom_nested_entry_ = NULL; +static ffeinfoKind ffecom_primary_entry_kind_; +static bool ffecom_primary_entry_is_proc_; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree ffecom_outer_function_decl_; +static tree ffecom_previous_function_decl_; +static tree ffecom_which_entrypoint_decl_; +static ffecomTemp_ ffecom_latest_temp_; +static int ffecom_pending_calls_ = 0; +static tree ffecom_float_zero_ = NULL_TREE; +static tree ffecom_float_half_ = NULL_TREE; +static tree ffecom_double_zero_ = NULL_TREE; +static tree ffecom_double_half_ = NULL_TREE; +static tree ffecom_func_result_;/* For functions. */ +static tree ffecom_func_length_;/* For CHARACTER fns. */ +static ffebld ffecom_list_blockdata_; +static ffebld ffecom_list_common_; +static ffebld ffecom_master_arglist_; +static ffeinfoBasictype ffecom_master_bt_; +static ffeinfoKindtype ffecom_master_kt_; +static ffetargetCharacterSize ffecom_master_size_; +static int ffecom_num_fns_ = 0; +static int ffecom_num_entrypoints_ = 0; +static bool ffecom_is_altreturning_ = FALSE; +static tree ffecom_multi_type_node_; +static tree ffecom_multi_retval_; +static tree + ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype]; +static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */ +static bool ffecom_doing_entry_ = FALSE; +static bool ffecom_transform_only_dummies_ = FALSE; + +/* Holds pointer-to-function expressions. */ + +static tree ffecom_gfrt_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Holds the external names of the functions. */ + +static char *ffecom_gfrt_name_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Whether the function returns. */ + +static bool ffecom_gfrt_volatile_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Whether the function returns type complex. */ + +static bool ffecom_gfrt_complex_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Type code for the function return value. */ + +static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* String of codes for the function's arguments. */ + +static char *ffecom_gfrt_argstring_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS, +#include "com-rt.def" +#undef DEFGFRT +}; +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Internal macros. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + +/* We let tm.h override the types used here, to handle trivial differences + such as the choice of unsigned int or long unsigned int for size_t. + When machines start needing nontrivial differences in the size type, + it would be best to do something here to figure out automatically + from other information what type to use. */ + +/* NOTE: g77 currently doesn't use these; see setting of sizetype and + change that if you need to. -- jcb 09/01/91. */ + +#ifndef SIZE_TYPE +#define SIZE_TYPE "long unsigned int" +#endif + +#ifndef WCHAR_TYPE +#define WCHAR_TYPE "int" +#endif + +#define ffecom_concat_list_count_(catlist) ((catlist).count) +#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)]) +#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen) +#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen) + +#define ffecom_start_compstmt_ bison_rule_pushlevel_ +#define ffecom_end_compstmt_ bison_rule_compstmt_ + +/* For each binding contour we allocate a binding_level structure + * which records the names defined in that contour. + * Contours include: + * 0) the global one + * 1) one for each function definition, + * where internal declarations of the parameters appear. + * + * The current meaning of a name can be found by searching the levels from + * the current one out to the global one. + */ + +/* Note that the information in the `names' component of the global contour + is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */ + +struct binding_level + { + /* A chain of _DECL nodes for all variables, constants, functions, and + typedef types. These are in the reverse of the order supplied. */ + tree names; + + /* For each level (except not the global one), a chain of BLOCK nodes for + all the levels that were entered and exited one level down. */ + tree blocks; + + /* The BLOCK node for this level, if one has been preallocated. If 0, the + BLOCK is allocated (if needed) when the level is popped. */ + tree this_block; + + /* The binding level which this one is contained in (inherits from). */ + struct binding_level *level_chain; + }; + +#define NULL_BINDING_LEVEL (struct binding_level *) NULL + +/* The binding level currently in effect. */ + +static struct binding_level *current_binding_level; + +/* A chain of binding_level structures awaiting reuse. */ + +static struct binding_level *free_binding_level; + +/* The outermost binding level, for names of file scope. + This is created when the compiler is started and exists + through the entire run. */ + +static struct binding_level *global_binding_level; + +/* Binding level structures are initialized by copying this one. */ + +static struct binding_level clear_binding_level += +{NULL, NULL, NULL, NULL_BINDING_LEVEL}; + +/* Language-dependent contents of an identifier. */ + +struct lang_identifier + { + struct tree_identifier ignore; + tree global_value, local_value, label_value; + bool invented; + }; + +/* Macros for access to language-specific slots in an identifier. */ +/* Each of these slots contains a DECL node or null. */ + +/* This represents the value which the identifier has in the + file-scope namespace. */ +#define IDENTIFIER_GLOBAL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->global_value) +/* This represents the value which the identifier has in the current + scope. */ +#define IDENTIFIER_LOCAL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->local_value) +/* This represents the value which the identifier has as a label in + the current label scope. */ +#define IDENTIFIER_LABEL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->label_value) +/* This is nonzero if the identifier was "made up" by g77 code. */ +#define IDENTIFIER_INVENTED(NODE) \ + (((struct lang_identifier *)(NODE))->invented) + +/* In identifiers, C uses the following fields in a special way: + TREE_PUBLIC to record that there was a previous local extern decl. + TREE_USED to record that such a decl was used. + TREE_ADDRESSABLE to record that the address of such a decl was used. */ + +/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function + that have names. Here so we can clear out their names' definitions + at the end of the function. */ + +static tree named_labels; + +/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */ + +static tree shadowed_labels; + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + + +/* This is like gcc's stabilize_reference -- in fact, most of the code + comes from that -- but it handles the situation where the reference + is going to have its subparts picked at, and it shouldn't change + (or trigger extra invocations of functions in the subtrees) due to + this. save_expr is a bit overzealous, because we don't need the + entire thing calculated and saved like a temp. So, for DECLs, no + change is needed, because these are stable aggregates, and ARRAY_REF + and such might well be stable too, but for things like calculations, + we do need to calculate a snapshot of a value before picking at it. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_stabilize_aggregate_ (tree ref) +{ + tree result; + enum tree_code code = TREE_CODE (ref); + + switch (code) + { + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + /* No action is needed in this case. */ + return ref; + + case NOP_EXPR: + case CONVERT_EXPR: + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FIX_CEIL_EXPR: + result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0))); + break; + + case INDIRECT_REF: + result = build_nt (INDIRECT_REF, + stabilize_reference_1 (TREE_OPERAND (ref, 0))); + break; + + case COMPONENT_REF: + result = build_nt (COMPONENT_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + TREE_OPERAND (ref, 1)); + break; + + case BIT_FIELD_REF: + result = build_nt (BIT_FIELD_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + stabilize_reference_1 (TREE_OPERAND (ref, 1)), + stabilize_reference_1 (TREE_OPERAND (ref, 2))); + break; + + case ARRAY_REF: + result = build_nt (ARRAY_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + stabilize_reference_1 (TREE_OPERAND (ref, 1))); + break; + + case COMPOUND_EXPR: + result = build_nt (COMPOUND_EXPR, + stabilize_reference_1 (TREE_OPERAND (ref, 0)), + stabilize_reference (TREE_OPERAND (ref, 1))); + break; + + case RTL_EXPR: + result = build1 (INDIRECT_REF, TREE_TYPE (ref), + save_expr (build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ref)), + ref))); + break; + + + default: + return save_expr (ref); + + case ERROR_MARK: + return error_mark_node; + } + + TREE_TYPE (result) = TREE_TYPE (ref); + TREE_READONLY (result) = TREE_READONLY (ref); + TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + TREE_RAISES (result) = TREE_RAISES (ref); + + return result; +} +#endif + +/* A rip-off of gcc's convert.c convert_to_complex function, + reworked to handle complex implemented as C structures + (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_convert_to_complex_ (tree type, tree expr) +{ + register enum tree_code form = TREE_CODE (TREE_TYPE (expr)); + tree subtype; + + assert (TREE_CODE (type) == RECORD_TYPE); + + subtype = TREE_TYPE (TYPE_FIELDS (type)); + + if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE) + { + expr = convert (subtype, expr); + return ffecom_2 (COMPLEX_EXPR, type, expr, + convert (subtype, integer_zero_node)); + } + + if (form == RECORD_TYPE) + { + tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))); + if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype)) + return expr; + else + { + expr = save_expr (expr); + return ffecom_2 (COMPLEX_EXPR, + type, + convert (subtype, + ffecom_1 (REALPART_EXPR, + TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), + expr)), + convert (subtype, + ffecom_1 (IMAGPART_EXPR, + TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), + expr))); + } + } + + if (form == POINTER_TYPE || form == REFERENCE_TYPE) + error ("pointer value used where a complex was expected"); + else + error ("aggregate value used where a complex was expected"); + + return ffecom_2 (COMPLEX_EXPR, type, + convert (subtype, integer_zero_node), + convert (subtype, integer_zero_node)); +} +#endif + +/* Like gcc's convert(), but crashes if widening might happen. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_convert_narrow_ (type, expr) + tree type, expr; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + assert (code != VOID_TYPE); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + assert ("converting COMPLEX to REAL" == NULL); + assert (code != ENUMERAL_TYPE); + if (code == INTEGER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE); + assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_integer (type, e)); + } + if (code == POINTER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); + return fold (convert_to_pointer (type, e)); + } + if (code == REAL_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); + assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_real (type, e)); + } + if (code == COMPLEX_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); + return fold (convert_to_complex (type, e)); + } + if (code == RECORD_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) + <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); + return fold (ffecom_convert_to_complex_ (type, e)); + } + + assert ("conversion to non-scalar type requested" == NULL); + return error_mark_node; +} +#endif + +/* Like gcc's convert(), but crashes if narrowing might happen. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_convert_widen_ (type, expr) + tree type, expr; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + assert (code != VOID_TYPE); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + assert ("narrowing COMPLEX to REAL" == NULL); + assert (code != ENUMERAL_TYPE); + if (code == INTEGER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE); + assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_integer (type, e)); + } + if (code == POINTER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); + return fold (convert_to_pointer (type, e)); + } + if (code == REAL_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); + assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_real (type, e)); + } + if (code == COMPLEX_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); + return fold (convert_to_complex (type, e)); + } + if (code == RECORD_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) + >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); + return fold (ffecom_convert_to_complex_ (type, e)); + } + + assert ("conversion to non-scalar type requested" == NULL); + return error_mark_node; +} +#endif + +/* Handles making a COMPLEX type, either the standard + (but buggy?) gbe way, or the safer (but less elegant?) + f2c way. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_make_complex_type_ (tree subtype) +{ + tree type; + tree realfield; + tree imagfield; + + if (ffe_is_emulate_complex ()) + { + type = make_node (RECORD_TYPE); + realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype); + imagfield = ffecom_decl_field (type, realfield, "i", subtype); + TYPE_FIELDS (type) = realfield; + layout_type (type); + } + else + { + type = make_node (COMPLEX_TYPE); + TREE_TYPE (type) = subtype; + layout_type (type); + } + + return type; +} +#endif + +/* Chooses either the gbe or the f2c way to build a + complex constant. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart) +{ + tree bothparts; + + if (ffe_is_emulate_complex ()) + { + bothparts = build_tree_list (TYPE_FIELDS (type), realpart); + TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart); + bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts); + } + else + { + bothparts = build_complex (type, realpart, imagpart); + } + + return bothparts; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_arglist_expr_ (char *c, ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + ffebld exprh; + tree item; + bool ptr = FALSE; + tree wanted = NULL_TREE; + + while (expr != NULL) + { + if (*c != '\0') + { + ptr = FALSE; + if (*c == '&') + { + ptr = TRUE; + ++c; + } + switch (*(c++)) + { + case '\0': + ptr = TRUE; + wanted = NULL_TREE; + break; + + case 'a': + assert (ptr); + wanted = NULL_TREE; + break; + + case 'c': + wanted = ffecom_f2c_complex_type_node; + break; + + case 'd': + wanted = ffecom_f2c_doublereal_type_node; + break; + + case 'e': + wanted = ffecom_f2c_doublecomplex_type_node; + break; + + case 'f': + wanted = ffecom_f2c_real_type_node; + break; + + case 'i': + wanted = ffecom_f2c_integer_type_node; + break; + + case 'j': + wanted = ffecom_f2c_longint_type_node; + break; + + default: + assert ("bad argstring code" == NULL); + wanted = NULL_TREE; + break; + } + } + + exprh = ffebld_head (expr); + if (exprh == NULL) + wanted = NULL_TREE; + + if ((wanted == NULL_TREE) + || (ptr + && (TYPE_MODE + (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))] + [ffeinfo_kindtype (ffebld_info (exprh))]) + == TYPE_MODE (wanted)))) + *plist + = build_tree_list (NULL_TREE, + ffecom_arg_ptr_to_expr (exprh, + &length)); + else + { + item = ffecom_arg_expr (exprh, &length); + item = ffecom_convert_widen_ (wanted, item); + if (ptr) + { + item = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (item)), + item); + } + *plist + = build_tree_list (NULL_TREE, + item); + } + + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_widest_expr_type_ (ffebld list) +{ + ffebld item; + ffebld widest = NULL; + ffetype type; + ffetype widest_type = NULL; + tree t; + + for (; list != NULL; list = ffebld_trail (list)) + { + item = ffebld_head (list); + if (item == NULL) + continue; + if ((widest != NULL) + && (ffeinfo_basictype (ffebld_info (item)) + != ffeinfo_basictype (ffebld_info (widest)))) + continue; + type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)), + ffeinfo_kindtype (ffebld_info (item))); + if ((widest == FFEINFO_kindtypeNONE) + || (ffetype_size (type) + > ffetype_size (widest_type))) + { + widest = item; + widest_type = type; + } + } + + assert (widest != NULL); + t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))] + [ffeinfo_kindtype (ffebld_info (widest))]; + assert (t != NULL_TREE); + return t; +} +#endif + +/* Check whether dest and source might overlap. ffebld versions of these + might or might not be passed, will be NULL if not. + + The test is really whether source_tree is modifiable and, if modified, + might overlap destination such that the value(s) in the destination might + change before it is finally modified. dest_* are the canonized + destination itself. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static bool +ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size, + tree source_tree, ffebld source UNUSED, + bool scalar_arg) +{ + tree source_decl; + tree source_offset; + tree source_size; + tree t; + + if (source_tree == NULL_TREE) + return FALSE; + + switch (TREE_CODE (source_tree)) + { + case ERROR_MARK: + case IDENTIFIER_NODE: + case INTEGER_CST: + case REAL_CST: + case COMPLEX_CST: + case STRING_CST: + case CONST_DECL: + case VAR_DECL: + case RESULT_DECL: + case FIELD_DECL: + case MINUS_EXPR: + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case ROUND_DIV_EXPR: + case TRUNC_MOD_EXPR: + case CEIL_MOD_EXPR: + case FLOOR_MOD_EXPR: + case ROUND_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case FIX_TRUNC_EXPR: + case FIX_CEIL_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FLOAT_EXPR: + case EXPON_EXPR: + case NEGATE_EXPR: + case MIN_EXPR: + case MAX_EXPR: + case ABS_EXPR: + case FFS_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_ANDTC_EXPR: + case BIT_NOT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + case LABEL_EXPR: + case COMPONENT_REF: + return FALSE; + + case COMPOUND_EXPR: + return ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 1), NULL, + scalar_arg); + + case MODIFY_EXPR: + return ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 0), NULL, + scalar_arg); + + case CONVERT_EXPR: + case NOP_EXPR: + case NON_LVALUE_EXPR: + case PLUS_EXPR: + if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) + return TRUE; + + ffecom_tree_canonize_ptr_ (&source_decl, &source_offset, + source_tree); + source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); + break; + + case COND_EXPR: + return + ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 1), NULL, + scalar_arg) + || ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 2), NULL, + scalar_arg); + + + case ADDR_EXPR: + ffecom_tree_canonize_ref_ (&source_decl, &source_offset, + &source_size, + TREE_OPERAND (source_tree, 0)); + break; + + case PARM_DECL: + if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) + return TRUE; + + source_decl = source_tree; + source_offset = size_zero_node; + source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); + break; + + case SAVE_EXPR: + case REFERENCE_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case INDIRECT_REF: + case ARRAY_REF: + case CALL_EXPR: + default: + return TRUE; + } + + /* Come here when source_decl, source_offset, and source_size filled + in appropriately. */ + + if (source_decl == NULL_TREE) + return FALSE; /* No decl involved, so no overlap. */ + + if (source_decl != dest_decl) + return FALSE; /* Different decl, no overlap. */ + + if (TREE_CODE (dest_size) == ERROR_MARK) + return TRUE; /* Assignment into entire assumed-size + array? Shouldn't happen.... */ + + t = ffecom_2 (LE_EXPR, integer_type_node, + ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset), + dest_offset, + convert (TREE_TYPE (dest_offset), + dest_size)), + convert (TREE_TYPE (dest_offset), + source_offset)); + + if (integer_onep (t)) + return FALSE; /* Destination precedes source. */ + + if (!scalar_arg + || (source_size == NULL_TREE) + || (TREE_CODE (source_size) == ERROR_MARK) + || integer_zerop (source_size)) + return TRUE; /* No way to tell if dest follows source. */ + + t = ffecom_2 (LE_EXPR, integer_type_node, + ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset), + source_offset, + convert (TREE_TYPE (source_offset), + source_size)), + convert (TREE_TYPE (source_offset), + dest_offset)); + + if (integer_onep (t)) + return FALSE; /* Destination follows source. */ + + return TRUE; /* Destination and source overlap. */ +} +#endif + +/* Check whether dest might overlap any of a list of arguments or is + in a COMMON area the callee might know about (and thus modify). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static bool +ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED, + tree args, tree callee_commons, + bool scalar_args) +{ + tree arg; + tree dest_decl; + tree dest_offset; + tree dest_size; + + ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size, + dest_tree); + + if (dest_decl == NULL_TREE) + return FALSE; /* Seems unlikely! */ + + /* If the decl cannot be determined reliably, or if its in COMMON + and the callee isn't known to not futz with COMMON via other + means, overlap might happen. */ + + if ((TREE_CODE (dest_decl) == ERROR_MARK) + || ((callee_commons != NULL_TREE) + && TREE_PUBLIC (dest_decl))) + return TRUE; + + for (; args != NULL_TREE; args = TREE_CHAIN (args)) + { + if (((arg = TREE_VALUE (args)) != NULL_TREE) + && ffecom_overlap_ (dest_decl, dest_offset, dest_size, + arg, NULL, scalar_args)) + return TRUE; + } + + return FALSE; +} +#endif + +/* Build a string for a variable name as used by NAMELIST. This means that + if we're using the f2c library, we build an uppercase string, since + f2c does this. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_build_f2c_string_ (int i, char *s) +{ + if (!ffe_is_f2c_library ()) + return build_string (i, s); + + { + char *tmp; + char *p; + char *q; + char space[34]; + tree t; + + if (((size_t) i) > ARRAY_SIZE (space)) + tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i); + else + tmp = &space[0]; + + for (p = s, q = tmp; *p != '\0'; ++p, ++q) + *q = ffesrc_toupper (*p); + *q = '\0'; + + t = build_string (i, tmp); + + if (((size_t) i) > ARRAY_SIZE (space)) + malloc_kill_ks (malloc_pool_image (), tmp, i); + + return t; + } +} + +#endif +/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for + type to just get whatever the function returns), handling the + f2c value-returning convention, if required, by prepending + to the arglist a pointer to a temporary to receive the return value. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, + tree type, tree args, tree dest_tree, + ffebld dest, bool *dest_used, tree callee_commons, + bool scalar_args) +{ + tree item; + tree tempvar; + + if (dest_used != NULL) + *dest_used = FALSE; + + if (is_f2c_complex) + { + if ((dest_used == NULL) + || (dest == NULL) + || (ffeinfo_basictype (ffebld_info (dest)) + != FFEINFO_basictypeCOMPLEX) + || (ffeinfo_kindtype (ffebld_info (dest)) != kt) + || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type)) + || ffecom_args_overlapping_ (dest_tree, dest, args, + callee_commons, + scalar_args)) + { + tempvar = ffecom_push_tempvar (ffecom_tree_type + [FFEINFO_basictypeCOMPLEX][kt], + FFETARGET_charactersizeNONE, + -1, TRUE); + } + else + { + *dest_used = TRUE; + tempvar = dest_tree; + type = NULL_TREE; + } + + item + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar)); + TREE_CHAIN (item) = args; + + item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, + item, NULL_TREE); + + if (tempvar != dest_tree) + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar); + } + else + item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, + args, NULL_TREE); + + if ((type != NULL_TREE) && (TREE_TYPE (item) != type)) + item = ffecom_convert_narrow_ (type, item); + + return item; +} +#endif + +/* Given two arguments, transform them and make a call to the given + function via ffecom_call_. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, + tree type, ffebld left, ffebld right, + tree dest_tree, ffebld dest, bool *dest_used, + tree callee_commons, bool scalar_args) +{ + tree left_tree; + tree right_tree; + tree left_length; + tree right_length; + + ffecom_push_calltemps (); + left_tree = ffecom_arg_ptr_to_expr (left, &left_length); + right_tree = ffecom_arg_ptr_to_expr (right, &right_length); + ffecom_pop_calltemps (); + + left_tree = build_tree_list (NULL_TREE, left_tree); + right_tree = build_tree_list (NULL_TREE, right_tree); + TREE_CHAIN (left_tree) = right_tree; + + if (left_length != NULL_TREE) + { + left_length = build_tree_list (NULL_TREE, left_length); + TREE_CHAIN (right_tree) = left_length; + } + + if (right_length != NULL_TREE) + { + right_length = build_tree_list (NULL_TREE, right_length); + if (left_length != NULL_TREE) + TREE_CHAIN (left_length) = right_length; + else + TREE_CHAIN (right_tree) = right_length; + } + + return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree, + dest_tree, dest, dest_used, callee_commons, + scalar_args); +} +#endif + +/* ffecom_char_args_ -- Return ptr/length args for char subexpression + + tree ptr_arg; + tree length_arg; + ffebld expr; + ffecom_char_args_(&ptr_arg,&length_arg,expr); + + Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF + subexpressions by constructing the appropriate trees for the ptr-to- + character-text and length-of-character-text arguments in a calling + sequence. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_char_args_ (tree *xitem, tree *length, ffebld expr) +{ + tree item; + tree high; + ffetargetCharacter1 val; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + val = ffebld_constant_character1 (ffebld_conter (expr)); + *length = build_int_2 (ffetarget_length_character1 (val), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + high = build_int_2 (ffetarget_length_character1 (val), + 0); + TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + item = build_string (ffetarget_length_character1 (val), + ffetarget_text_character1 (val)); + TREE_TYPE (item) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type + (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + high)), + 1, 0); + TREE_CONSTANT (item) = 1; + TREE_STATIC (item) = 1; + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + break; + + case FFEBLD_opSYMTER: + { + ffesymbol s = ffebld_symter (expr); + + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (ffesymbol_kind (s) == FFEINFO_kindENTITY) + { + if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) + *length = ffesymbol_hook (s).length_tree; + else + { + *length = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } + } + else if (item == error_mark_node) + *length = error_mark_node; + else /* FFEINFO_kindFUNCTION: */ + *length = NULL_TREE; + if (!ffesymbol_hook (s).addr + && (item != error_mark_node)) + item = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (item)), + item); + } + break; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; + tree array; + int i; + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + { + item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)), + item, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + } + } + break; + + case FFEBLD_opSUBSTR: + { + ffebld start; + ffebld end; + ffebld thing = ffebld_right (expr); + tree start_tree; + tree end_tree; + + assert (ffebld_op (thing) == FFEBLD_opITEM); + start = ffebld_head (thing); + thing = ffebld_trail (thing); + assert (ffebld_trail (thing) == NULL); + end = ffebld_head (thing); + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if (start == NULL) + { + if (end == NULL) + ; + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + *length = end_tree; + } + } + else + { + start_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (start)); + + if (start_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + start_tree = ffecom_save_tree (start_tree); + + item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item), + item, + ffecom_2 (MINUS_EXPR, + TREE_TYPE (start_tree), + start_tree, + ffecom_f2c_ftnlen_one_node)); + + if (end == NULL) + { + *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + *length, + start_tree)); + } + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + end_tree, start_tree)); + } + } + } + break; + + case FFEBLD_opFUNCREF: + { + ffesymbol s = ffebld_symter (ffebld_left (expr)); + tree tempvar; + tree args; + ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr)); + ffecomGfrt ix; + + if (size == FFETARGET_charactersizeNONE) + size = 24; /* ~~~~ Kludge alert! This should someday be fixed. */ + + *length = build_int_2 (size, 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + + if (ffeinfo_where (ffebld_info (ffebld_left (expr))) + == FFEINFO_whereINTRINSIC) + { + if (size == 1) + { /* Invocation of an intrinsic returning CHARACTER*1. */ + item = ffecom_expr_intrinsic_ (expr, NULL_TREE, + NULL, NULL); + break; + } + ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr))); + assert (ix != FFECOM_gfrt); + item = ffecom_gfrt_tree_ (ix); + } + else + { + ix = FFECOM_gfrt; + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (item == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if (!ffesymbol_hook (s).addr) + item = ffecom_1_fn (item); + } + + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE); + tempvar = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar); + + ffecom_push_calltemps (); + + args = build_tree_list (NULL_TREE, tempvar); + + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */ + TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr)); + else + { + TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length); + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + TREE_CHAIN (TREE_CHAIN (args)) + = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix), + ffebld_right (expr)); + } + else + { + TREE_CHAIN (TREE_CHAIN (args)) + = ffecom_list_ptr_to_expr (ffebld_right (expr)); + } + } + + item = ffecom_3s (CALL_EXPR, + TREE_TYPE (TREE_TYPE (TREE_TYPE (item))), + item, args, NULL_TREE); + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, + tempvar); + + ffecom_pop_calltemps (); + } + break; + + case FFEBLD_opCONVERT: + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if ((ffebld_size_known (ffebld_left (expr)) + == FFETARGET_charactersizeNONE) + || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr)))) + { /* Possible blank-padding needed, copy into + temporary. */ + tree tempvar; + tree args; + tree newlen; + + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, + ffebld_size (expr), -1, TRUE); + tempvar = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar); + + newlen = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node; + + args = build_tree_list (NULL_TREE, tempvar); + TREE_CHAIN (args) = build_tree_list (NULL_TREE, item); + TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args))) + = build_tree_list (NULL_TREE, *length); + + item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args); + TREE_SIDE_EFFECTS (item) = 1; + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item), + tempvar); + *length = newlen; + } + else + { /* Just truncate the length. */ + *length = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } + break; + + default: + assert ("bad op for single char arg expr" == NULL); + item = NULL_TREE; + break; + } + + *xitem = item; +} +#endif + +/* Check the size of the type to be sure it doesn't overflow the + "portable" capacities of the compiler back end. `dummy' types + can generally overflow the normal sizes as long as the computations + themselves don't overflow. A particular target of the back end + must still enforce its size requirements, though, and the back + end takes care of this in stor-layout.c. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy) +{ + if (TREE_CODE (type) == ERROR_MARK) + return type; + + if (TYPE_SIZE (type) == NULL_TREE) + return type; + + if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST) + return type; + + if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0) + || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0)) + || TREE_OVERFLOW (TYPE_SIZE (type))) + { + ffebad_start (FFEBAD_ARRAY_LARGE); + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); + ffebad_finish (); + + return error_mark_node; + } + + return type; +} +#endif + +/* Builds a length argument (PARM_DECL). Also wraps type in an array type + where the dimension info is (1:size) where <size> is ffesymbol_size(s) if + known, length_arg if not known (FFETARGET_charactersizeNONE). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s) +{ + ffetargetCharacterSize sz = ffesymbol_size (s); + tree highval; + tree tlen; + tree type = *xtype; + + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + tlen = NULL_TREE; /* A statement function, no length passed. */ + else + { + if (ffesymbol_where (s) == FFEINFO_whereDUMMY) + tlen = ffecom_get_invented_identifier ("__g77_length_%s", + ffesymbol_text (s), 0); + else + tlen = ffecom_get_invented_identifier ("__g77_%s", + "length", 0); + tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (tlen) = 1; +#endif + } + + if (sz == FFETARGET_charactersizeNONE) + { + assert (tlen != NULL_TREE); + highval = tlen; + } + else + { + highval = build_int_2 (sz, 0); + TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node; + } + + type = build_array_type (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + highval)); + + *xtype = type; + return tlen; +} + +#endif +/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs + + ffecomConcatList_ catlist; + ffebld expr; // expr of CHARACTER basictype. + ffetargetCharacterSize max; // max chars to gather or _...NONE if no max + catlist = ffecom_concat_list_gather_(catlist,expr,max); + + Scans expr for character subexpressions, updates and returns catlist + accordingly. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffecomConcatList_ +ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr, + ffetargetCharacterSize max) +{ + ffetargetCharacterSize sz; + +recurse: /* :::::::::::::::::::: */ + + if (expr == NULL) + return catlist; + + if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max)) + return catlist; /* Don't append any more items. */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + case FFEBLD_opCONVERT: /* Callers should strip this off beforehand + if they don't need to preserve it. */ + if (catlist.count == catlist.max) + { /* Make a (larger) list. */ + ffebld *newx; + int newmax; + + newmax = (catlist.max == 0) ? 8 : catlist.max * 2; + newx = malloc_new_ks (malloc_pool_image (), "catlist", + newmax * sizeof (newx[0])); + if (catlist.max != 0) + { + memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0])); + malloc_kill_ks (malloc_pool_image (), catlist.exprs, + catlist.max * sizeof (newx[0])); + } + catlist.max = newmax; + catlist.exprs = newx; + } + if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE) + catlist.minlen += sz; + else + ++catlist.minlen; /* Not true for F90; can be 0 length. */ + if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE) + catlist.maxlen = sz; + else + catlist.maxlen += sz; + if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max)) + { /* This item overlaps (or is beyond) the end + of the destination. */ + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + break; /* ~~Do useful truncations here. */ + + default: + assert ("op changed or inconsistent switches!" == NULL); + break; + } + } + catlist.exprs[catlist.count++] = expr; + return catlist; + + case FFEBLD_opPAREN: + expr = ffebld_left (expr); + goto recurse; /* :::::::::::::::::::: */ + + case FFEBLD_opCONCATENATE: + catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max); + expr = ffebld_right (expr); + goto recurse; /* :::::::::::::::::::: */ + +#if 0 /* Breaks passing small actual arg to larger + dummy arg of sfunc */ + case FFEBLD_opCONVERT: + expr = ffebld_left (expr); + { + ffetargetCharacterSize cmax; + + cmax = catlist.len + ffebld_size_known (expr); + + if ((max == FFETARGET_charactersizeNONE) || (max > cmax)) + max = cmax; + } + goto recurse; /* :::::::::::::::::::: */ +#endif + + case FFEBLD_opANY: + return catlist; + + default: + assert ("bad op in _gather_" == NULL); + return catlist; + } +} + +#endif +/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs + + ffecomConcatList_ catlist; + ffecom_concat_list_kill_(catlist); + + Anything allocated within the list info is deallocated. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_concat_list_kill_ (ffecomConcatList_ catlist) +{ + if (catlist.max != 0) + malloc_kill_ks (malloc_pool_image (), catlist.exprs, + catlist.max * sizeof (catlist.exprs[0])); +} + +#endif +/* ffecom_concat_list_new_ -- Make list of concatenated string exprs + + ffecomConcatList_ catlist; + ffebld expr; // Root expr of CHARACTER basictype. + ffetargetCharacterSize max; // max chars to gather or _...NONE if no max + catlist = ffecom_concat_list_new_(expr,max); + + Returns a flattened list of concatenated subexpressions given a + tree of such expressions. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffecomConcatList_ +ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max) +{ + ffecomConcatList_ catlist; + + catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0; + return ffecom_concat_list_gather_ (catlist, expr, max); +} + +#endif + +/* Provide some kind of useful info on member of aggregate area, + since current g77/gcc technology does not provide debug info + on these members. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member, + tree member_type UNUSED, ffetargetOffset offset) +{ + tree value; + tree decl; + int len; + char *buff; + char space[120]; +#if 0 + tree type_id; + + for (type_id = member_type; + TREE_CODE (type_id) != IDENTIFIER_NODE; + ) + { + switch (TREE_CODE (type_id)) + { + case INTEGER_TYPE: + case REAL_TYPE: + type_id = TYPE_NAME (type_id); + break; + + case ARRAY_TYPE: + case COMPLEX_TYPE: + type_id = TREE_TYPE (type_id); + break; + + default: + assert ("no IDENTIFIER_NODE for type!" == NULL); + type_id = error_mark_node; + break; + } + } +#endif + + if (ffecom_transform_only_dummies_ + || !ffe_is_debug_kludge ()) + return; /* Can't do this yet, maybe later. */ + + len = 60 + + strlen (aggr_type) + + IDENTIFIER_LENGTH (DECL_NAME (aggr)); +#if 0 + + IDENTIFIER_LENGTH (type_id); +#endif + + if (((size_t) len) >= ARRAY_SIZE (space)) + buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1); + else + buff = &space[0]; + + sprintf (&buff[0], "At (%s) `%s' plus %ld bytes", + aggr_type, + IDENTIFIER_POINTER (DECL_NAME (aggr)), + (long int) offset); + + value = build_string (len, buff); + TREE_TYPE (value) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 (strlen (buff), 0))), + 1, 0); + decl = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (member)), + TREE_TYPE (value)); + TREE_CONSTANT (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_INITIAL (decl) = error_mark_node; + DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */ + decl = start_decl (decl, FALSE); + finish_decl (decl, value, FALSE); + + if (buff != &space[0]) + malloc_kill_ks (malloc_pool_image (), buff, len + 1); +} +#endif + +/* ffecom_do_entry_ -- Do compilation of a particular entrypoint + + ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself + int i; // entry# for this entrypoint (used by master fn) + ffecom_do_entrypoint_(s,i); + + Makes a public entry point that calls our private master fn (already + compiled). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_do_entry_ (ffesymbol fn, int entrynum) +{ + ffebld item; + tree type; /* Type of function. */ + tree multi_retval; /* Var holding return value (union). */ + tree result; /* Var holding result. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + ffeglobalType gt; + bool charfunc; /* All entry points return same type + CHARACTER. */ + bool cmplxfunc; /* Use f2c way of returning COMPLEX. */ + bool multi; /* Master fn has multiple return types. */ + bool altreturning = FALSE; /* This entry point has alternate returns. */ + int yes; + + /* c-parse.y indeed does call suspend_momentary and not only ignores the + return value, but also never calls resume_momentary, when starting an + outer function (see "fndef:", "setspecs:", and so on). So g77 does the + same thing. It shouldn't be a problem since start_function calls + temporary_allocation, but it might be necessary. If it causes a problem + here, then maybe there's a bug lurking in gcc. NOTE: This identical + comment appears twice in thist file. */ + + suspend_momentary (); + + ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */ + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindFUNCTION: + + /* Determine actual return type for function. */ + + gt = FFEGLOBAL_typeFUNC; + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + if (bt == FFEINFO_basictypeNONE) + { + ffeimplic_establish_symbol (fn); + if (ffesymbol_funcresult (fn) != NULL) + ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + } + + if (bt == FFEINFO_basictypeCHARACTER) + charfunc = TRUE, cmplxfunc = FALSE; + else if ((bt == FFEINFO_basictypeCOMPLEX) + && ffesymbol_is_f2c (fn)) + charfunc = FALSE, cmplxfunc = TRUE; + else + charfunc = cmplxfunc = FALSE; + + if (charfunc) + type = ffecom_tree_fun_type_void; + else if (ffesymbol_is_f2c (fn)) + type = ffecom_tree_fun_type[bt][kt]; + else + type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + if ((type == NULL_TREE) + || (TREE_TYPE (type) == NULL_TREE)) + type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ + + multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE); + break; + + case FFEINFO_kindSUBROUTINE: + gt = FFEGLOBAL_typeSUBR; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + if (ffecom_is_altreturning_) + { /* Am _I_ altreturning? */ + for (item = ffesymbol_dummyargs (fn); + item != NULL; + item = ffebld_trail (item)) + { + if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR) + { + altreturning = TRUE; + break; + } + } + if (altreturning) + type = ffecom_tree_subr_type; + else + type = ffecom_tree_fun_type_void; + } + else + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + multi = FALSE; + break; + + default: + assert ("say what??" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + gt = FFEGLOBAL_typeANY; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = error_mark_node; + charfunc = FALSE; + cmplxfunc = FALSE; + multi = FALSE; + break; + } + + /* build_decl uses the current lineno and input_filename to set the decl + source info. So, I've putzed with ffestd and ffeste code to update that + source info to point to the appropriate statement just before calling + ffecom_do_entrypoint (which calls this fn). */ + + start_function (ffecom_get_external_identifier_ (fn), + type, + 0, /* nested/inline */ + 1); /* TREE_PUBLIC */ + + if (((g = ffesymbol_global (fn)) != NULL) + && ((ffeglobal_type (g) == gt) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + { + ffeglobal_set_hook (g, current_function_decl); + } + + /* Reset args in master arg list so they get retransitioned. */ + + for (item = ffecom_master_arglist_; + item != NULL; + item = ffebld_trail (item)) + { + ffebld arg; + ffesymbol s; + + arg = ffebld_head (item); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + s = ffebld_symter (arg); + ffesymbol_hook (s).decl_tree = NULL_TREE; + ffesymbol_hook (s).length_tree = NULL_TREE; + } + + /* Build dummy arg list for this entry point. */ + + yes = suspend_momentary (); + + if (charfunc || cmplxfunc) + { /* Prepend arg for where result goes. */ + tree type; + tree length; + + if (charfunc) + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + else + type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + /* Make length arg _and_ enhance type info for CHAR arg itself. */ + + if (charfunc) + length = ffecom_char_enhance_arg_ (&type, fn); + else + length = NULL_TREE; /* Not ref'd if !charfunc. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + ffecom_func_result_ = result; + + if (charfunc) + { + push_parm_decl (length); + ffecom_func_length_ = length; + } + } + else + result = DECL_RESULT (current_function_decl); + + ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE); + + resume_momentary (yes); + + store_parm_decls (0); + + ffecom_start_compstmt_ (); + + /* Make local var to hold return type for multi-type master fn. */ + + if (multi) + { + yes = suspend_momentary (); + + multi_retval = ffecom_get_invented_identifier ("__g77_%s", + "multi_retval", 0); + multi_retval = build_decl (VAR_DECL, multi_retval, + ffecom_multi_type_node_); + multi_retval = start_decl (multi_retval, FALSE); + finish_decl (multi_retval, NULL_TREE, FALSE); + + resume_momentary (yes); + } + else + multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */ + + /* Here we emit the actual code for the entry point. */ + + { + ffebld list; + ffebld arg; + ffesymbol s; + tree arglist = NULL_TREE; + tree *plist = &arglist; + tree prepend; + tree call; + tree actarg; + tree master_fn; + + /* Prepare actual arg list based on master arg list. */ + + for (list = ffecom_master_arglist_; + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; + s = ffebld_symter (arg); + if (ffesymbol_hook (s).decl_tree == NULL_TREE) + actarg = null_pointer_node; /* We don't have this arg. */ + else + actarg = ffesymbol_hook (s).decl_tree; + *plist = build_tree_list (NULL_TREE, actarg); + plist = &TREE_CHAIN (*plist); + } + + /* This code appends the length arguments for character + variables/arrays. */ + + for (list = ffecom_master_arglist_; + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; + s = ffebld_symter (arg); + if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) + continue; /* Only looking for CHARACTER arguments. */ + if (ffesymbol_kind (s) != FFEINFO_kindENTITY) + continue; /* Only looking for variables and arrays. */ + if (ffesymbol_hook (s).length_tree == NULL_TREE) + actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */ + else + actarg = ffesymbol_hook (s).length_tree; + *plist = build_tree_list (NULL_TREE, actarg); + plist = &TREE_CHAIN (*plist); + } + + /* Prepend character-value return info to actual arg list. */ + + if (charfunc) + { + prepend = build_tree_list (NULL_TREE, ffecom_func_result_); + TREE_CHAIN (prepend) + = build_tree_list (NULL_TREE, ffecom_func_length_); + TREE_CHAIN (TREE_CHAIN (prepend)) = arglist; + arglist = prepend; + } + + /* Prepend multi-type return value to actual arg list. */ + + if (multi) + { + prepend + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (multi_retval)), + multi_retval)); + TREE_CHAIN (prepend) = arglist; + arglist = prepend; + } + + /* Prepend my entry-point number to the actual arg list. */ + + prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0)); + TREE_CHAIN (prepend) = arglist; + arglist = prepend; + + /* Build the call to the master function. */ + + master_fn = ffecom_1_fn (ffecom_previous_function_decl_); + call = ffecom_3s (CALL_EXPR, + TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))), + master_fn, arglist, NULL_TREE); + + /* Decide whether the master function is a function or subroutine, and + handle the return value for my entry point. */ + + if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) + && !altreturning)) + { + expand_expr_stmt (call); + expand_null_return (); + } + else if (multi && cmplxfunc) + { + expand_expr_stmt (call); + result + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), + result); + result = ffecom_modify (NULL_TREE, result, + ffecom_2 (COMPONENT_REF, TREE_TYPE (result), + multi_retval, + ffecom_multi_fields_[bt][kt])); + expand_expr_stmt (result); + expand_null_return (); + } + else if (multi) + { + expand_expr_stmt (call); + result + = ffecom_modify (NULL_TREE, result, + convert (TREE_TYPE (result), + ffecom_2 (COMPONENT_REF, + ffecom_tree_type[bt][kt], + multi_retval, + ffecom_multi_fields_[bt][kt]))); + expand_return (result); + } + else if (cmplxfunc) + { + result + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), + result); + result = ffecom_modify (NULL_TREE, result, call); + expand_expr_stmt (result); + expand_null_return (); + } + else + { + result = ffecom_modify (NULL_TREE, + result, + convert (TREE_TYPE (result), + call)); + expand_return (result); + } + + clear_momentary (); + } + + ffecom_end_compstmt_ (); + + finish_function (0); + + ffecom_doing_entry_ = FALSE; +} + +#endif +/* Transform expr into gcc tree with possible destination + + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. If destination supplied and compatible + with temporary that would be made in certain cases, temporary isn't + made, destination used instead, and dest_used flag set TRUE. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_expr_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used, + bool assignp) +{ + tree item; + tree list; + tree args; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree t; + tree tree_type; + tree dt; /* decl_tree for an ffesymbol. */ + ffesymbol s; + enum tree_code code; + + assert (expr != NULL); + + if (dest_used != NULL) + *dest_used = FALSE; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + switch (ffebld_op (expr)) + { + case FFEBLD_opACCTER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffebitCount i; + ffebit bits = ffebld_accter_bits (expr); + ffetargetOffset source_offset = 0; + size_t size; + tree purpose; + + size = ffetype_size (ffeinfo_type (bt, kt)); + + list = item = NULL; + for (;;) + { + ffebldConstantUnion cu; + ffebitCount length; + bool value; + ffebldConstantArray ca = ffebld_accter (expr); + + ffebit_test (bits, source_offset, &value, &length); + if (length == 0) + break; + + if (value) + { + for (i = 0; i < length; ++i) + { + cu = ffebld_constantarray_get (ca, bt, kt, + source_offset + i); + + t = ffecom_constantunion (&cu, bt, kt, tree_type); + + if (i == 0) + purpose = build_int_2 (source_offset, 0); + else + purpose = NULL_TREE; + + if (list == NULL_TREE) + list = item = build_tree_list (purpose, t); + else + { + TREE_CHAIN (item) = build_tree_list (purpose, t); + item = TREE_CHAIN (item); + } + } + } + source_offset += length; + } + } + + item = build_int_2 (ffebld_accter_size (expr), 0); + ffebit_kill (ffebld_accter_bits (expr)); + TREE_TYPE (item) = ffecom_integer_type_node; + item + = build_array_type + (tree_type, + build_range_type (ffecom_integer_type_node, + ffecom_integer_zero_node, + item)); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + return list; + + case FFEBLD_opARRTER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffetargetOffset i; + + list = item = NULL_TREE; + for (i = 0; i < ffebld_arrter_size (expr); ++i) + { + ffebldConstantUnion cu + = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i); + + t = ffecom_constantunion (&cu, bt, kt, tree_type); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + } + + item = build_int_2 (ffebld_arrter_size (expr), 0); + TREE_TYPE (item) = ffecom_integer_type_node; + item + = build_array_type + (tree_type, + build_range_type (ffecom_integer_type_node, + ffecom_integer_one_node, + item)); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + return list; + + case FFEBLD_opCONTER: + tree_type = ffecom_tree_type[bt][kt]; + item + = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)), + bt, kt, tree_type); + return item; + + case FFEBLD_opSYMTER: + if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE) + || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE)) + return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */ + s = ffebld_symter (expr); + t = ffesymbol_hook (s).decl_tree; + + if (assignp) + { /* ASSIGN'ed-label expr. */ + if (ffe_is_ugly_assign ()) + { + /* User explicitly wants ASSIGN'ed variables to be at the same + memory address as the variables when used in non-ASSIGN + contexts. That can make old, arcane, non-standard code + work, but don't try to do it when a pointer wouldn't fit + in the normal variable (take other approach, and warn, + instead). */ + + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + assert (t != NULL_TREE); + } + + if (t == error_mark_node) + return t; + + if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t))) + >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) + { + if (ffesymbol_hook (s).addr) + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); + return t; + } + + if (ffesymbol_hook (s).assign_tree == NULL_TREE) + { + ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling", + FFEBAD_severityWARNING); + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_finish (); + } + } + + /* Don't use the normal variable's tree for ASSIGN, though mark + it as in the system header (housekeeping). Use an explicit, + specially created sibling that is known to be wide enough + to hold pointers to labels. */ + + if (t != NULL_TREE + && TREE_CODE (t) == VAR_DECL) + DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */ + + t = ffesymbol_hook (s).assign_tree; + if (t == NULL_TREE) + { + s = ffecom_sym_transform_assign_ (s); + t = ffesymbol_hook (s).assign_tree; + assert (t != NULL_TREE); + } + } + else + { + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + assert (t != NULL_TREE); + } + if (ffesymbol_hook (s).addr) + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); + } + return t; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; +#if FFECOM_FASTER_ARRAY_REFS + tree array; +#endif + int i; + +#if FFECOM_FASTER_ARRAY_REFS + t = ffecom_ptr_to_expr (ffebld_left (expr)); +#else + t = ffecom_expr (ffebld_left (expr)); +#endif + if (t == error_mark_node) + return t; + + if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) + && !mark_addressable (t)) + return error_mark_node; /* Make sure non-const ref is to + non-reg. */ + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + +#if FFECOM_FASTER_ARRAY_REFS + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + t = ffecom_2 (PLUS_EXPR, + build_pointer_type (TREE_TYPE (array)), + t, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), + t); +#else + while (i > 0) + t = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), + t, + ffecom_expr (dims[--i])); +#endif + + return t; + } + + case FFEBLD_opUPLUS: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opPAREN: /* ~~~Make sure Fortran rules respected here */ + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opUMINUS: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NEGATE_EXPR, tree_type, + ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opADD: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (PLUS_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + break; + + case FFEBLD_opSUBTRACT: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (MINUS_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + case FFEBLD_opMULTIPLY: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (MULT_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + case FFEBLD_opDIVIDE: + tree_type = ffecom_tree_type[bt][kt]; + return + ffecom_tree_divide_ (tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr)), + dest_tree, dest, dest_used); + + case FFEBLD_opPOWER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffebld left = ffebld_left (expr); + ffebld right = ffebld_right (expr); + ffecomGfrt code; + ffeinfoKindtype rtkt; + + switch (ffeinfo_basictype (ffebld_info (right))) + { + case FFEINFO_basictypeINTEGER: + if (1 || optimize) + { + item = ffecom_expr_power_integer_ (left, right); + if (item != NULL_TREE) + return item; + } + + rtkt = FFEINFO_kindtypeINTEGER1; + switch (ffeinfo_basictype (ffebld_info (left))) + { + case FFEINFO_basictypeINTEGER: + if ((ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeINTEGER4) + || (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeINTEGER4)) + { + code = FFECOM_gfrtPOW_QQ; + rtkt = FFEINFO_kindtypeINTEGER4; + } + else + code = FFECOM_gfrtPOW_II; + break; + + case FFEINFO_basictypeREAL: + if (ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeREAL1) + code = FFECOM_gfrtPOW_RI; + else + code = FFECOM_gfrtPOW_DI; + break; + + case FFEINFO_basictypeCOMPLEX: + if (ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeREAL1) + code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ + else + code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */ + break; + + default: + assert ("bad pow_*i" == NULL); + code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ + break; + } + if (ffeinfo_kindtype (ffebld_info (left)) != rtkt) + left = ffeexpr_convert (left, NULL, NULL, + FFEINFO_basictypeINTEGER, + rtkt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) != rtkt) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeINTEGER, + rtkt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeREAL: + if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) + left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeREAL1) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + code = FFECOM_gfrtPOW_DD; + break; + + case FFEINFO_basictypeCOMPLEX: + if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) + left = ffeexpr_convert (left, NULL, NULL, + FFEINFO_basictypeCOMPLEX, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeREAL1) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeCOMPLEX, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */ + break; + + default: + assert ("bad pow_x*" == NULL); + code = FFECOM_gfrtPOW_II; + break; + } + return ffecom_call_binop_ (ffecom_gfrt_tree_ (code), + ffecom_gfrt_kindtype (code), + (ffe_is_f2c_library () + && ffecom_gfrt_complex_[code]), + tree_type, left, right, + dest_tree, dest, dest_used, + NULL_TREE, FALSE); + } + + case FFEBLD_opNOT: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_expr (ffebld_left (expr))); + + default: + assert ("NOT bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opFUNCREF: + assert (ffeinfo_basictype (ffebld_info (expr)) + != FFEINFO_basictypeCHARACTER); + /* Fall through. */ + case FFEBLD_opSUBRREF: + tree_type = ffecom_tree_type[bt][kt]; + if (ffeinfo_where (ffebld_info (ffebld_left (expr))) + == FFEINFO_whereINTRINSIC) + { /* Invocation of an intrinsic. */ + item = ffecom_expr_intrinsic_ (expr, dest_tree, dest, + dest_used); + return item; + } + s = ffebld_symter (ffebld_left (expr)); + dt = ffesymbol_hook (s).decl_tree; + if (dt == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + dt = ffesymbol_hook (s).decl_tree; + } + if (dt == error_mark_node) + return dt; + + if (ffesymbol_hook (s).addr) + item = dt; + else + item = ffecom_1_fn (dt); + + ffecom_push_calltemps (); + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + args = ffecom_list_expr (ffebld_right (expr)); + else + args = ffecom_list_ptr_to_expr (ffebld_right (expr)); + ffecom_pop_calltemps (); + + item = ffecom_call_ (item, kt, + ffesymbol_is_f2c (s) + && (bt == FFEINFO_basictypeCOMPLEX) + && (ffesymbol_where (s) + != FFEINFO_whereCONSTANT), + tree_type, + args, + dest_tree, dest, dest_used, + error_mark_node, FALSE); + TREE_SIDE_EFFECTS (item) = 1; + return item; + + case FFEBLD_opAND: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_truth_value (ffecom_expr (ffebld_left (expr))), + ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("AND bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opOR: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + ffecom_truth_value (ffecom_expr (ffebld_left (expr))), + ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("OR bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opXOR: + case FFEBLD_opNEQV: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (NE_EXPR, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, ffecom_truth_value (item)); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_XOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("XOR/NEQV bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opEQV: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, ffecom_truth_value (item)); + + case FFEINFO_basictypeINTEGER: + return + ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_2 (BIT_XOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr)))); + + default: + assert ("EQV bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opCONVERT: + if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY) + return error_mark_node; + + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + return convert (tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeREAL: + item = ffecom_expr (ffebld_left (expr)); + if (item == error_mark_node) + return error_mark_node; + /* convert() takes care of converting to the subtype first, + at least in gcc-2.7.2. */ + item = convert (tree_type, item); + return item; + + case FFEINFO_basictypeCOMPLEX: + return convert (tree_type, ffecom_expr (ffebld_left (expr))); + + default: + assert ("CONVERT COMPLEX bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + default: + assert ("CONVERT bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opLT: + code = LT_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opLE: + code = LE_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opEQ: + code = EQ_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opNE: + code = NE_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opGT: + code = GT_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opGE: + code = GE_EXPR; + + relational: /* :::::::::::::::::::: */ + + tree_type = ffecom_tree_type[bt][kt]; + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + item = ffecom_2 (code, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, item); + + case FFEINFO_basictypeCOMPLEX: + assert (code == EQ_EXPR || code == NE_EXPR); + { + tree real_type; + tree arg1 = ffecom_expr (ffebld_left (expr)); + tree arg2 = ffecom_expr (ffebld_right (expr)); + + if (arg1 == error_mark_node || arg2 == error_mark_node) + return error_mark_node; + + arg1 = ffecom_save_tree (arg1); + arg2 = ffecom_save_tree (arg2); + + if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE) + { + real_type = TREE_TYPE (TREE_TYPE (arg1)); + assert (real_type == TREE_TYPE (TREE_TYPE (arg2))); + } + else + { + real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1))); + assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2)))); + } + + item + = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (REALPART_EXPR, real_type, arg1), + ffecom_1 (REALPART_EXPR, real_type, arg2)), + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (IMAGPART_EXPR, real_type, arg1), + ffecom_1 (IMAGPART_EXPR, real_type, + arg2))); + if (code == EQ_EXPR) + item = ffecom_truth_value (item); + else + item = ffecom_truth_value_invert (item); + return convert (tree_type, item); + } + + case FFEINFO_basictypeCHARACTER: + ffecom_push_calltemps (); /* Even though we might not call. */ + + { + ffebld left = ffebld_left (expr); + ffebld right = ffebld_right (expr); + tree left_tree; + tree right_tree; + tree left_length; + tree right_length; + + /* f2c run-time functions do the implicit blank-padding for us, + so we don't usually have to implement blank-padding ourselves. + (The exception is when we pass an argument to a separately + compiled statement function -- if we know the arg is not the + same length as the dummy, we must truncate or extend it. If + we "inline" statement functions, that necessity goes away as + well.) + + Strip off the CONVERT operators that blank-pad. (Truncation by + CONVERT shouldn't happen here, but it can happen in + assignments.) */ + + while (ffebld_op (left) == FFEBLD_opCONVERT) + left = ffebld_left (left); + while (ffebld_op (right) == FFEBLD_opCONVERT) + right = ffebld_left (right); + + left_tree = ffecom_arg_ptr_to_expr (left, &left_length); + right_tree = ffecom_arg_ptr_to_expr (right, &right_length); + + if (left_tree == error_mark_node || left_length == error_mark_node + || right_tree == error_mark_node + || right_length == error_mark_node) + { + ffecom_pop_calltemps (); + return error_mark_node; + } + + if ((ffebld_size_known (left) == 1) + && (ffebld_size_known (right) == 1)) + { + left_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), + left_tree); + right_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), + right_tree); + + item + = ffecom_2 (code, integer_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), + left_tree, + integer_one_node), + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), + right_tree, + integer_one_node)); + } + else + { + item = build_tree_list (NULL_TREE, left_tree); + TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree); + TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE, + left_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) + = build_tree_list (NULL_TREE, right_length); + item = ffecom_call_gfrt (FFECOM_gfrtCMP, item); + item = ffecom_2 (code, integer_type_node, + item, + convert (TREE_TYPE (item), + integer_zero_node)); + } + item = convert (tree_type, item); + } + + ffecom_pop_calltemps (); + return item; + + default: + assert ("relational bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opPERCENT_LOC: + tree_type = ffecom_tree_type[bt][kt]; + item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list); + return convert (tree_type, item); + + case FFEBLD_opITEM: + case FFEBLD_opSTAR: + case FFEBLD_opBOUNDS: + case FFEBLD_opREPEAT: + case FFEBLD_opLABTER: + case FFEBLD_opLABTOK: + case FFEBLD_opIMPDO: + case FFEBLD_opCONCATENATE: + case FFEBLD_opSUBSTR: + default: + assert ("bad op" == NULL); + /* Fall through. */ + case FFEBLD_opANY: + return error_mark_node; + } + +#if 1 + assert ("didn't think anything got here anymore!!" == NULL); +#else + switch (ffebld_arity (expr)) + { + case 2: + TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); + TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr)); + if (TREE_OPERAND (item, 0) == error_mark_node + || TREE_OPERAND (item, 1) == error_mark_node) + return error_mark_node; + break; + + case 1: + TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); + if (TREE_OPERAND (item, 0) == error_mark_node) + return error_mark_node; + break; + + default: + break; + } + + return fold (item); +#endif +} + +#endif +/* Returns the tree that does the intrinsic invocation. + + Note: this function applies only to intrinsics returning + CHARACTER*1 or non-CHARACTER results, and to intrinsic + subroutines. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used) +{ + tree expr_tree; + tree saved_expr1; /* For those who need it. */ + tree saved_expr2; /* For those who need it. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree tree_type; + tree arg1_type; + tree real_type; /* REAL type corresponding to COMPLEX. */ + tree tempvar; + ffebld list = ffebld_right (expr); /* List of (some) args. */ + ffebld arg1; /* For handy reference. */ + ffebld arg2; + ffebld arg3; + ffeintrinImp codegen_imp; + ffecomGfrt gfrt; + + assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER); + + if (dest_used != NULL) + *dest_used = FALSE; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + tree_type = ffecom_tree_type[bt][kt]; + + if (list != NULL) + { + arg1 = ffebld_head (list); + if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY) + return error_mark_node; + if ((list = ffebld_trail (list)) != NULL) + { + arg2 = ffebld_head (list); + if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY) + return error_mark_node; + if ((list = ffebld_trail (list)) != NULL) + { + arg3 = ffebld_head (list); + if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY) + return error_mark_node; + } + else + arg3 = NULL; + } + else + arg2 = arg3 = NULL; + } + else + arg1 = arg2 = arg3 = NULL; + + /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3 + args. This is used by the MAX/MIN expansions. */ + + if (arg1 != NULL) + arg1_type = ffecom_tree_type + [ffeinfo_basictype (ffebld_info (arg1))] + [ffeinfo_kindtype (ffebld_info (arg1))]; + else + arg1_type = NULL_TREE; /* Really not needed, but might catch bugs + here. */ + + /* There are several ways for each of the cases in the following switch + statements to exit (from simplest to use to most complicated): + + break; (when expr_tree == NULL) + + A standard call is made to the specific intrinsic just as if it had been + passed in as a dummy procedure and called as any old procedure. This + method can produce slower code but in some cases it's the easiest way for + now. However, if a (presumably faster) direct call is available, + that is used, so this is the easiest way in many more cases now. + + gfrt = FFECOM_gfrtWHATEVER; + break; + + gfrt contains the gfrt index of a library function to call, passing the + argument(s) by value rather than by reference. Used when a more + careful choice of library function is needed than that provided + by the vanilla `break;'. + + return expr_tree; + + The expr_tree has been completely set up and is ready to be returned + as is. No further actions are taken. Use this when the tree is not + in the simple form for one of the arity_n labels. */ + + /* For info on how the switch statement cases were written, see the files + enclosed in comments below the switch statement. */ + + codegen_imp = ffebld_symter_implementation (ffebld_left (expr)); + gfrt = ffeintrin_gfrt_direct (codegen_imp); + if (gfrt == FFECOM_gfrt) + gfrt = ffeintrin_gfrt_indirect (codegen_imp); + + switch (codegen_imp) + { + case FFEINTRIN_impABS: + case FFEINTRIN_impCABS: + case FFEINTRIN_impCDABS: + case FFEINTRIN_impDABS: + case FFEINTRIN_impIABS: + if (ffeinfo_basictype (ffebld_info (arg1)) + == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCABS; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDABS; + break; + } + return ffecom_1 (ABS_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1))); + + case FFEINTRIN_impACOS: + case FFEINTRIN_impDACOS: + break; + + case FFEINTRIN_impAIMAG: + case FFEINTRIN_impDIMAG: + case FFEINTRIN_impIMAGPART: + if (TREE_CODE (arg1_type) == COMPLEX_TYPE) + arg1_type = TREE_TYPE (arg1_type); + else + arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); + + return + convert (tree_type, + ffecom_1 (IMAGPART_EXPR, arg1_type, + ffecom_expr (arg1))); + + case FFEINTRIN_impAINT: + case FFEINTRIN_impDINT: +#if 0 /* ~~ someday implement FIX_TRUNC_EXPR + yielding same type as arg */ + return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1)); +#else /* in the meantime, must use floor to avoid range problems with ints */ + /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (tree_type, + ffecom_3 (COND_EXPR, double_type_node, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + saved_expr1))), + ffecom_1 (NEGATE_EXPR, double_type_node, + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_1 (NEGATE_EXPR, + arg1_type, + saved_expr1)))) + )) + ); +#endif + + case FFEINTRIN_impANINT: + case FFEINTRIN_impDNINT: +#if 0 /* This way of doing it won't handle real + numbers of large magnitudes. */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + expr_tree = convert (tree_type, + convert (integer_type_node, + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, + integer_type_node, + saved_expr1, + ffecom_float_zero_)), + ffecom_2 (PLUS_EXPR, + tree_type, + saved_expr1, + ffecom_float_half_), + ffecom_2 (MINUS_EXPR, + tree_type, + saved_expr1, + ffecom_float_half_)))); + return expr_tree; +#else /* So we instead call floor. */ + /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (tree_type, + ffecom_3 (COND_EXPR, double_type_node, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_2 (PLUS_EXPR, + arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_))))), + ffecom_1 (NEGATE_EXPR, double_type_node, + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_2 (MINUS_EXPR, + arg1_type, + convert (arg1_type, + ffecom_float_half_), + saved_expr1))))) + ) + ); +#endif + + case FFEINTRIN_impASIN: + case FFEINTRIN_impDASIN: + case FFEINTRIN_impATAN: + case FFEINTRIN_impDATAN: + case FFEINTRIN_impATAN2: + case FFEINTRIN_impDATAN2: + break; + + case FFEINTRIN_impCHAR: + case FFEINTRIN_impACHAR: + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, + 1, -1, TRUE); + { + tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar))); + + expr_tree = ffecom_modify (tmv, + ffecom_2 (ARRAY_REF, tmv, tempvar, + integer_one_node), + convert (tmv, ffecom_expr (arg1))); + } + expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), + expr_tree, + tempvar); + expr_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (expr_tree)), + expr_tree); + return expr_tree; + + case FFEINTRIN_impCMPLX: + case FFEINTRIN_impDCMPLX: + if (arg2 == NULL) + return + convert (tree_type, ffecom_expr (arg1)); + + real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + return + ffecom_2 (COMPLEX_EXPR, tree_type, + convert (real_type, ffecom_expr (arg1)), + convert (real_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impCOMPLEX: + return + ffecom_2 (COMPLEX_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_expr (arg2)); + + case FFEINTRIN_impCONJG: + case FFEINTRIN_impDCONJG: + { + tree arg1_tree; + + real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + return + ffecom_2 (COMPLEX_EXPR, tree_type, + ffecom_1 (REALPART_EXPR, real_type, arg1_tree), + ffecom_1 (NEGATE_EXPR, real_type, + ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree))); + } + + case FFEINTRIN_impCOS: + case FFEINTRIN_impCCOS: + case FFEINTRIN_impCDCOS: + case FFEINTRIN_impDCOS: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impCOSH: + case FFEINTRIN_impDCOSH: + break; + + case FFEINTRIN_impDBLE: + case FFEINTRIN_impDFLOAT: + case FFEINTRIN_impDREAL: + case FFEINTRIN_impFLOAT: + case FFEINTRIN_impIDINT: + case FFEINTRIN_impIFIX: + case FFEINTRIN_impINT2: + case FFEINTRIN_impINT8: + case FFEINTRIN_impINT: + case FFEINTRIN_impLONG: + case FFEINTRIN_impREAL: + case FFEINTRIN_impSHORT: + case FFEINTRIN_impSNGL: + return convert (tree_type, ffecom_expr (arg1)); + + case FFEINTRIN_impDIM: + case FFEINTRIN_impDDIM: + case FFEINTRIN_impIDIM: + saved_expr1 = ffecom_save_tree (convert (tree_type, + ffecom_expr (arg1))); + saved_expr2 = ffecom_save_tree (convert (tree_type, + ffecom_expr (arg2))); + return + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + saved_expr1, + saved_expr2)), + ffecom_2 (MINUS_EXPR, tree_type, + saved_expr1, + saved_expr2), + convert (tree_type, ffecom_float_zero_)); + + case FFEINTRIN_impDPROD: + return + ffecom_2 (MULT_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1)), + convert (tree_type, ffecom_expr (arg2))); + + case FFEINTRIN_impEXP: + case FFEINTRIN_impCDEXP: + case FFEINTRIN_impCEXP: + case FFEINTRIN_impDEXP: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impICHAR: + case FFEINTRIN_impIACHAR: +#if 0 /* The simple approach. */ + ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1); + expr_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree); + expr_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree, + integer_one_node); + return convert (tree_type, expr_tree); +#else /* The more interesting (and more optimal) approach. */ + expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1); + expr_tree = ffecom_3 (COND_EXPR, tree_type, + saved_expr1, + expr_tree, + convert (tree_type, integer_zero_node)); + return expr_tree; +#endif + + case FFEINTRIN_impINDEX: + break; + + case FFEINTRIN_impLEN: +#if 0 + break; /* The simple approach. */ +#else + return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */ +#endif + + case FFEINTRIN_impLGE: + case FFEINTRIN_impLGT: + case FFEINTRIN_impLLE: + case FFEINTRIN_impLLT: + break; + + case FFEINTRIN_impLOG: + case FFEINTRIN_impALOG: + case FFEINTRIN_impCDLOG: + case FFEINTRIN_impCLOG: + case FFEINTRIN_impDLOG: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impLOG10: + case FFEINTRIN_impALOG10: + case FFEINTRIN_impDLOG10: + if (gfrt != FFECOM_gfrt) + break; /* Already picked one, stick with it. */ + + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtALOG10; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtDLOG10; + break; + + case FFEINTRIN_impMAX: + case FFEINTRIN_impAMAX0: + case FFEINTRIN_impAMAX1: + case FFEINTRIN_impDMAX1: + case FFEINTRIN_impMAX0: + case FFEINTRIN_impMAX1: + if (bt != ffeinfo_basictype (ffebld_info (arg1))) + arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); + else + arg1_type = tree_type; + expr_tree = ffecom_2 (MAX_EXPR, arg1_type, + convert (arg1_type, ffecom_expr (arg1)), + convert (arg1_type, ffecom_expr (arg2))); + for (; list != NULL; list = ffebld_trail (list)) + { + if ((ffebld_head (list) == NULL) + || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) + continue; + expr_tree = ffecom_2 (MAX_EXPR, arg1_type, + expr_tree, + convert (arg1_type, + ffecom_expr (ffebld_head (list)))); + } + return convert (tree_type, expr_tree); + + case FFEINTRIN_impMIN: + case FFEINTRIN_impAMIN0: + case FFEINTRIN_impAMIN1: + case FFEINTRIN_impDMIN1: + case FFEINTRIN_impMIN0: + case FFEINTRIN_impMIN1: + if (bt != ffeinfo_basictype (ffebld_info (arg1))) + arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); + else + arg1_type = tree_type; + expr_tree = ffecom_2 (MIN_EXPR, arg1_type, + convert (arg1_type, ffecom_expr (arg1)), + convert (arg1_type, ffecom_expr (arg2))); + for (; list != NULL; list = ffebld_trail (list)) + { + if ((ffebld_head (list) == NULL) + || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) + continue; + expr_tree = ffecom_2 (MIN_EXPR, arg1_type, + expr_tree, + convert (arg1_type, + ffecom_expr (ffebld_head (list)))); + } + return convert (tree_type, expr_tree); + + case FFEINTRIN_impMOD: + case FFEINTRIN_impAMOD: + case FFEINTRIN_impDMOD: + if (bt != FFEINFO_basictypeREAL) + return ffecom_2 (TRUNC_MOD_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1)), + convert (tree_type, ffecom_expr (arg2))); + + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtAMOD; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtDMOD; + break; + + case FFEINTRIN_impNINT: + case FFEINTRIN_impIDNINT: +#if 0 /* ~~ ideally FIX_ROUND_EXPR would be + implemented, but it ain't yet */ + return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1)); +#else + /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (ffecom_integer_type_node, + ffecom_3 (COND_EXPR, arg1_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_2 (PLUS_EXPR, arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_)), + ffecom_2 (MINUS_EXPR, arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_)))); +#endif + + case FFEINTRIN_impSIGN: + case FFEINTRIN_impDSIGN: + case FFEINTRIN_impISIGN: + { + tree arg2_tree = ffecom_expr (arg2); + + saved_expr1 + = ffecom_save_tree + (ffecom_1 (ABS_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)))); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + arg2_tree, + convert (TREE_TYPE (arg2_tree), + integer_zero_node))), + saved_expr1, + ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1)); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, saved_expr1), + expr_tree); + } + return expr_tree; + + case FFEINTRIN_impSIN: + case FFEINTRIN_impCDSIN: + case FFEINTRIN_impCSIN: + case FFEINTRIN_impDSIN: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impSINH: + case FFEINTRIN_impDSINH: + break; + + case FFEINTRIN_impSQRT: + case FFEINTRIN_impCDSQRT: + case FFEINTRIN_impCSQRT: + case FFEINTRIN_impDSQRT: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impTAN: + case FFEINTRIN_impDTAN: + case FFEINTRIN_impTANH: + case FFEINTRIN_impDTANH: + break; + + case FFEINTRIN_impREALPART: + if (TREE_CODE (arg1_type) == COMPLEX_TYPE) + arg1_type = TREE_TYPE (arg1_type); + else + arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); + + return + convert (tree_type, + ffecom_1 (REALPART_EXPR, arg1_type, + ffecom_expr (arg1))); + + case FFEINTRIN_impIAND: + case FFEINTRIN_impAND: + return ffecom_2 (BIT_AND_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impIOR: + case FFEINTRIN_impOR: + return ffecom_2 (BIT_IOR_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impIEOR: + case FFEINTRIN_impXOR: + return ffecom_2 (BIT_XOR_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impLSHIFT: + return ffecom_2 (LSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))); + + case FFEINTRIN_impRSHIFT: + return ffecom_2 (RSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))); + + case FFEINTRIN_impNOT: + return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1)); + + case FFEINTRIN_impBIT_SIZE: + return convert (tree_type, TYPE_SIZE (arg1_type)); + + case FFEINTRIN_impBTEST: + { + ffetargetLogical1 true; + ffetargetLogical1 false; + tree true_tree; + tree false_tree; + + ffetarget_logical1 (&true, TRUE); + ffetarget_logical1 (&false, FALSE); + if (true == 1) + true_tree = convert (tree_type, integer_one_node); + else + true_tree = convert (tree_type, build_int_2 (true, 0)); + if (false == 0) + false_tree = convert (tree_type, integer_zero_node); + else + false_tree = convert (tree_type, build_int_2 (false, 0)); + + return + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_2 (BIT_AND_EXPR, arg1_type, + ffecom_expr (arg1), + ffecom_2 (LSHIFT_EXPR, arg1_type, + convert (arg1_type, + integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2)))), + convert (arg1_type, + integer_zero_node))), + false_tree, + true_tree); + } + + case FFEINTRIN_impIBCLR: + return + ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_2 (LSHIFT_EXPR, tree_type, + convert (tree_type, + integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2))))); + + case FFEINTRIN_impIBITS: + { + tree arg3_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg3))); + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + expr_tree + = ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_2 (RSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + ffecom_1 (BIT_NOT_EXPR, + uns_type, + convert (uns_type, + integer_zero_node)), + ffecom_2 (MINUS_EXPR, + integer_type_node, + TYPE_SIZE (uns_type), + arg3_tree)))); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + integer_zero_node)), + expr_tree, + convert (tree_type, integer_zero_node)); +#endif + } + return expr_tree; + + case FFEINTRIN_impIBSET: + return + ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_2 (LSHIFT_EXPR, tree_type, + convert (tree_type, integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2)))); + + case FFEINTRIN_impISHFT: + { + tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + tree arg2_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg2))); + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + arg2_tree, + integer_zero_node)), + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + arg2_tree), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, arg1_tree), + ffecom_1 (NEGATE_EXPR, + integer_type_node, + arg2_tree)))); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg2_tree, + TYPE_SIZE (uns_type))), + expr_tree, + convert (tree_type, integer_zero_node)); +#endif + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg1_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg2_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impISHFTC: + { + tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + tree arg2_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg2))); + tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type) + : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3))); + tree shift_neg; + tree shift_pos; + tree mask_arg1; + tree masked_arg1; + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + mask_arg1 + = ffecom_2 (LSHIFT_EXPR, tree_type, + ffecom_1 (BIT_NOT_EXPR, tree_type, + convert (tree_type, integer_zero_node)), + arg3_tree); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + mask_arg1 + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + TYPE_SIZE (uns_type))), + mask_arg1, + convert (tree_type, integer_zero_node)); +#endif + mask_arg1 = ffecom_save_tree (mask_arg1); + masked_arg1 + = ffecom_2 (BIT_AND_EXPR, tree_type, + arg1_tree, + ffecom_1 (BIT_NOT_EXPR, tree_type, + mask_arg1)); + masked_arg1 = ffecom_save_tree (masked_arg1); + shift_neg + = ffecom_2 (BIT_IOR_EXPR, tree_type, + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, masked_arg1), + ffecom_1 (NEGATE_EXPR, + integer_type_node, + arg2_tree))), + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + ffecom_2 (PLUS_EXPR, integer_type_node, + arg2_tree, + arg3_tree))); + shift_pos + = ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + arg2_tree), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, masked_arg1), + ffecom_2 (MINUS_EXPR, + integer_type_node, + arg3_tree, + arg2_tree)))); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + arg2_tree, + integer_zero_node)), + shift_neg, + shift_pos); + expr_tree + = ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_2 (BIT_AND_EXPR, tree_type, + mask_arg1, + arg1_tree), + ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_1 (BIT_NOT_EXPR, tree_type, + mask_arg1), + expr_tree)); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (ABS_EXPR, + integer_type_node, + arg2_tree), + arg3_tree), + ffecom_2 (EQ_EXPR, integer_type_node, + arg2_tree, + integer_zero_node))), + arg1_tree, + expr_tree); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg1_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg2_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + mask_arg1), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + masked_arg1), + expr_tree)))); + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + arg3_tree), + expr_tree); + } + return expr_tree; + + case FFEINTRIN_impLOC: + { + tree arg1_tree = ffecom_expr (arg1); + + expr_tree + = convert (tree_type, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree)); + } + return expr_tree; + + case FFEINTRIN_impMVBITS: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + ffebld arg4 = ffebld_head (ffebld_trail (list)); + tree arg4_tree; + tree arg4_type; + ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list))); + tree arg5_tree; + tree prep_arg1; + tree prep_arg4; + tree arg5_plus_arg3; + + ffecom_push_calltemps (); + + arg2_tree = convert (integer_type_node, + ffecom_expr (arg2)); + arg3_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg3))); + arg4_tree = ffecom_expr_rw (arg4); + arg4_type = TREE_TYPE (arg4_tree); + + arg1_tree = ffecom_save_tree (convert (arg4_type, + ffecom_expr (arg1))); + + arg5_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg5))); + + ffecom_pop_calltemps (); + + prep_arg1 + = ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_2 (BIT_AND_EXPR, arg4_type, + ffecom_2 (RSHIFT_EXPR, arg4_type, + arg1_tree, + arg2_tree), + ffecom_1 (BIT_NOT_EXPR, arg4_type, + ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, + arg4_type, + convert + (arg4_type, + integer_zero_node)), + arg3_tree))), + arg5_tree); + arg5_plus_arg3 + = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type, + arg5_tree, + arg3_tree)); + prep_arg4 + = ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, arg4_type, + convert (arg4_type, + integer_zero_node)), + arg5_plus_arg3); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + prep_arg4 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg5_plus_arg3, + convert (TREE_TYPE (arg5_plus_arg3), + TYPE_SIZE (arg4_type)))), + prep_arg4, + convert (arg4_type, integer_zero_node)); +#endif + prep_arg4 + = ffecom_2 (BIT_AND_EXPR, arg4_type, + arg4_tree, + ffecom_2 (BIT_IOR_EXPR, arg4_type, + prep_arg4, + ffecom_1 (BIT_NOT_EXPR, arg4_type, + ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, + arg4_type, + convert + (arg4_type, + integer_zero_node)), + arg5_tree)))); + prep_arg1 + = ffecom_2 (BIT_IOR_EXPR, arg4_type, + prep_arg1, + prep_arg4); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + prep_arg1 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + convert (TREE_TYPE (arg3_tree), + integer_zero_node))), + prep_arg1, + arg4_tree); + prep_arg1 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + convert (TREE_TYPE (arg3_tree), + TYPE_SIZE (arg4_type)))), + prep_arg1, + arg1_tree); +#endif + expr_tree + = ffecom_2s (MODIFY_EXPR, void_type_node, + arg4_tree, + prep_arg1); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, void_type_node, + arg1_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg3_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg5_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg5_plus_arg3, + expr_tree)))); + expr_tree + = ffecom_2 (COMPOUND_EXPR, void_type_node, + arg4_tree, + expr_tree); + + } + return expr_tree; + + case FFEINTRIN_impDERF: + case FFEINTRIN_impERF: + case FFEINTRIN_impDERFC: + case FFEINTRIN_impERFC: + break; + + case FFEINTRIN_impIARGC: + /* extern int xargc; i__1 = xargc - 1; */ + expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_), + ffecom_tree_xargc_, + convert (TREE_TYPE (ffecom_tree_xargc_), + integer_one_node)); + return expr_tree; + + case FFEINTRIN_impSIGNAL_func: + case FFEINTRIN_impSIGNAL_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + /* Pass procedure as a pointer to it, anything else by value. */ + if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) + arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); + else + arg2_tree = ffecom_ptr_to_expr (arg2); + arg2_tree = convert (TREE_TYPE (null_pointer_node), + arg2_tree); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ? + NULL_TREE : + tree_type), + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg3_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impALARM: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + /* Pass procedure as a pointer to it, anything else by value. */ + if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) + arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); + else + arg2_tree = ffecom_ptr_to_expr (arg2); + arg2_tree = convert (TREE_TYPE (null_pointer_node), + arg2_tree); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg3_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impCHDIR_subr: + case FFEINTRIN_impFDATE_subr: + case FFEINTRIN_impFGET_subr: + case FFEINTRIN_impFPUT_subr: + case FFEINTRIN_impGETCWD_subr: + case FFEINTRIN_impHOSTNM_subr: + case FFEINTRIN_impSYSTEM_subr: + case FFEINTRIN_impUNLINK_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + if (arg2 != NULL) + arg2_tree = ffecom_expr_rw (arg2); + else + arg2_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + TREE_CHAIN (arg1_tree) = arg1_len; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg2_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg2_tree, + convert (TREE_TYPE (arg2_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impEXIT: + if (arg1 != NULL) + break; + + expr_tree = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type + (ffecom_integer_type_node), + integer_zero_node)); + + return + ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + void_type_node, + expr_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + case FFEINTRIN_impFLUSH: + if (arg1 == NULL) + gfrt = FFECOM_gfrtFLUSH; + else + gfrt = FFECOM_gfrtFLUSH1; + break; + + case FFEINTRIN_impCHMOD_subr: + case FFEINTRIN_impLINK_subr: + case FFEINTRIN_impRENAME_subr: + case FFEINTRIN_impSYMLNK_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_len = integer_zero_node; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + arg2_len = build_tree_list (NULL_TREE, arg2_len); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg1_len; + TREE_CHAIN (arg1_len) = arg2_len; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impLSTAT_subr: + case FFEINTRIN_impSTAT_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + arg2_tree = ffecom_ptr_to_expr (arg2); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg1_len; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impFGETC_subr: + case FFEINTRIN_impFPUTC_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg2_len = integer_zero_node; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + arg2_len = build_tree_list (NULL_TREE, arg2_len); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg2_len; + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impFSTAT_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node, + ffecom_ptr_to_expr (arg2)); + + if (arg3 == NULL) + arg3_tree = NULL_TREE; + else + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impKILL_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg2)); + arg2_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg2_tree)), + arg2_tree); + + if (arg3 == NULL) + arg3_tree = NULL_TREE; + else + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impCTIME_subr: + case FFEINTRIN_impTTYNAM_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ? + ffecom_f2c_longint_type_node : + ffecom_f2c_integer_type_node), + ffecom_expr (arg2)); + arg2_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg2_tree)), + arg2_tree); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_len) = arg2_tree; + TREE_CHAIN (arg1_tree) = arg1_len; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + } + return expr_tree; + + case FFEINTRIN_impIRAND: + case FFEINTRIN_impRAND: + /* Arg defaults to 0 (normal random case) */ + { + tree arg1_tree; + + if (arg1 == NULL) + arg1_tree = ffecom_integer_zero_node; + else + arg1_tree = ffecom_expr (arg1); + arg1_tree = convert (ffecom_f2c_integer_type_node, + arg1_tree); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + ((codegen_imp == FFEINTRIN_impIRAND) ? + ffecom_f2c_integer_type_node : + ffecom_f2c_doublereal_type_node), + arg1_tree, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + return expr_tree; + + case FFEINTRIN_impFTELL_subr: + case FFEINTRIN_impUMASK_subr: + { + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + if (arg2 == NULL) + arg2_tree = NULL_TREE; + else + arg2_tree = ffecom_expr_rw (arg2); + + ffecom_pop_calltemps (); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + build_tree_list (NULL_TREE, arg1_tree), + NULL_TREE, NULL, NULL, NULL_TREE, + TRUE); + if (arg2_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg2_tree, + convert (TREE_TYPE (arg2_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impCPU_TIME: + case FFEINTRIN_impSECOND_subr: + { + tree arg1_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_expr_rw (arg1); + + ffecom_pop_calltemps (); + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + NULL_TREE, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + expr_tree + = ffecom_modify (NULL_TREE, arg1_tree, + convert (TREE_TYPE (arg1_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impDTIME_subr: + case FFEINTRIN_impETIME_subr: + { + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_expr_rw (arg1); + + arg2_tree = ffecom_ptr_to_expr (arg2); + + ffecom_pop_calltemps (); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + build_tree_list (NULL_TREE, arg2_tree), + NULL_TREE, NULL, NULL, NULL_TREE, + TRUE); + expr_tree = ffecom_modify (NULL_TREE, arg1_tree, + convert (TREE_TYPE (arg1_tree), + expr_tree)); + } + return expr_tree; + + /* Straightforward calls of libf2c routines: */ + case FFEINTRIN_impABORT: + case FFEINTRIN_impACCESS: + case FFEINTRIN_impBESJ0: + case FFEINTRIN_impBESJ1: + case FFEINTRIN_impBESJN: + case FFEINTRIN_impBESY0: + case FFEINTRIN_impBESY1: + case FFEINTRIN_impBESYN: + case FFEINTRIN_impCHDIR_func: + case FFEINTRIN_impCHMOD_func: + case FFEINTRIN_impDATE: + case FFEINTRIN_impDBESJ0: + case FFEINTRIN_impDBESJ1: + case FFEINTRIN_impDBESJN: + case FFEINTRIN_impDBESY0: + case FFEINTRIN_impDBESY1: + case FFEINTRIN_impDBESYN: + case FFEINTRIN_impDTIME_func: + case FFEINTRIN_impETIME_func: + case FFEINTRIN_impFGETC_func: + case FFEINTRIN_impFGET_func: + case FFEINTRIN_impFNUM: + case FFEINTRIN_impFPUTC_func: + case FFEINTRIN_impFPUT_func: + case FFEINTRIN_impFSEEK: + case FFEINTRIN_impFSTAT_func: + case FFEINTRIN_impFTELL_func: + case FFEINTRIN_impGERROR: + case FFEINTRIN_impGETARG: + case FFEINTRIN_impGETCWD_func: + case FFEINTRIN_impGETENV: + case FFEINTRIN_impGETGID: + case FFEINTRIN_impGETLOG: + case FFEINTRIN_impGETPID: + case FFEINTRIN_impGETUID: + case FFEINTRIN_impGMTIME: + case FFEINTRIN_impHOSTNM_func: + case FFEINTRIN_impIDATE_unix: + case FFEINTRIN_impIDATE_vxt: + case FFEINTRIN_impIERRNO: + case FFEINTRIN_impISATTY: + case FFEINTRIN_impITIME: + case FFEINTRIN_impKILL_func: + case FFEINTRIN_impLINK_func: + case FFEINTRIN_impLNBLNK: + case FFEINTRIN_impLSTAT_func: + case FFEINTRIN_impLTIME: + case FFEINTRIN_impMCLOCK8: + case FFEINTRIN_impMCLOCK: + case FFEINTRIN_impPERROR: + case FFEINTRIN_impRENAME_func: + case FFEINTRIN_impSECNDS: + case FFEINTRIN_impSECOND_func: + case FFEINTRIN_impSLEEP: + case FFEINTRIN_impSRAND: + case FFEINTRIN_impSTAT_func: + case FFEINTRIN_impSYMLNK_func: + case FFEINTRIN_impSYSTEM_CLOCK: + case FFEINTRIN_impSYSTEM_func: + case FFEINTRIN_impTIME8: + case FFEINTRIN_impTIME_unix: + case FFEINTRIN_impTIME_vxt: + case FFEINTRIN_impUMASK_func: + case FFEINTRIN_impUNLINK_func: + break; + + case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impNONE: + case FFEINTRIN_imp: /* Hush up gcc warning. */ + fprintf (stderr, "No %s implementation.\n", + ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr)))); + assert ("unimplemented intrinsic" == NULL); + return error_mark_node; + } + + assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */ + + ffecom_push_calltemps (); + expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), + ffebld_right (expr)); + ffecom_pop_calltemps (); + + return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt), + (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]), + tree_type, + expr_tree, dest_tree, dest, dest_used, + NULL_TREE, TRUE); + + /**INDENT* (Do not reformat this comment even with -fca option.) + Data-gathering files: Given the source file listed below, compiled with + f2c I obtained the output file listed after that, and from the output + file I derived the above code. + +-------- (begin input file to f2c) + implicit none + character*10 A1,A2 + complex C1,C2 + integer I1,I2 + real R1,R2 + double precision D1,D2 +C + call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) +c / + call fooI(I1/I2) + call fooR(R1/I1) + call fooD(D1/I1) + call fooC(C1/I1) + call fooR(R1/R2) + call fooD(R1/D1) + call fooD(D1/D2) + call fooD(D1/R1) + call fooC(C1/C2) + call fooC(C1/R1) + call fooZ(C1/D1) +c ** + call fooI(I1**I2) + call fooR(R1**I1) + call fooD(D1**I1) + call fooC(C1**I1) + call fooR(R1**R2) + call fooD(R1**D1) + call fooD(D1**D2) + call fooD(D1**R1) + call fooC(C1**C2) + call fooC(C1**R1) + call fooZ(C1**D1) +c FFEINTRIN_impABS + call fooR(ABS(R1)) +c FFEINTRIN_impACOS + call fooR(ACOS(R1)) +c FFEINTRIN_impAIMAG + call fooR(AIMAG(C1)) +c FFEINTRIN_impAINT + call fooR(AINT(R1)) +c FFEINTRIN_impALOG + call fooR(ALOG(R1)) +c FFEINTRIN_impALOG10 + call fooR(ALOG10(R1)) +c FFEINTRIN_impAMAX0 + call fooR(AMAX0(I1,I2)) +c FFEINTRIN_impAMAX1 + call fooR(AMAX1(R1,R2)) +c FFEINTRIN_impAMIN0 + call fooR(AMIN0(I1,I2)) +c FFEINTRIN_impAMIN1 + call fooR(AMIN1(R1,R2)) +c FFEINTRIN_impAMOD + call fooR(AMOD(R1,R2)) +c FFEINTRIN_impANINT + call fooR(ANINT(R1)) +c FFEINTRIN_impASIN + call fooR(ASIN(R1)) +c FFEINTRIN_impATAN + call fooR(ATAN(R1)) +c FFEINTRIN_impATAN2 + call fooR(ATAN2(R1,R2)) +c FFEINTRIN_impCABS + call fooR(CABS(C1)) +c FFEINTRIN_impCCOS + call fooC(CCOS(C1)) +c FFEINTRIN_impCEXP + call fooC(CEXP(C1)) +c FFEINTRIN_impCHAR + call fooA(CHAR(I1)) +c FFEINTRIN_impCLOG + call fooC(CLOG(C1)) +c FFEINTRIN_impCONJG + call fooC(CONJG(C1)) +c FFEINTRIN_impCOS + call fooR(COS(R1)) +c FFEINTRIN_impCOSH + call fooR(COSH(R1)) +c FFEINTRIN_impCSIN + call fooC(CSIN(C1)) +c FFEINTRIN_impCSQRT + call fooC(CSQRT(C1)) +c FFEINTRIN_impDABS + call fooD(DABS(D1)) +c FFEINTRIN_impDACOS + call fooD(DACOS(D1)) +c FFEINTRIN_impDASIN + call fooD(DASIN(D1)) +c FFEINTRIN_impDATAN + call fooD(DATAN(D1)) +c FFEINTRIN_impDATAN2 + call fooD(DATAN2(D1,D2)) +c FFEINTRIN_impDCOS + call fooD(DCOS(D1)) +c FFEINTRIN_impDCOSH + call fooD(DCOSH(D1)) +c FFEINTRIN_impDDIM + call fooD(DDIM(D1,D2)) +c FFEINTRIN_impDEXP + call fooD(DEXP(D1)) +c FFEINTRIN_impDIM + call fooR(DIM(R1,R2)) +c FFEINTRIN_impDINT + call fooD(DINT(D1)) +c FFEINTRIN_impDLOG + call fooD(DLOG(D1)) +c FFEINTRIN_impDLOG10 + call fooD(DLOG10(D1)) +c FFEINTRIN_impDMAX1 + call fooD(DMAX1(D1,D2)) +c FFEINTRIN_impDMIN1 + call fooD(DMIN1(D1,D2)) +c FFEINTRIN_impDMOD + call fooD(DMOD(D1,D2)) +c FFEINTRIN_impDNINT + call fooD(DNINT(D1)) +c FFEINTRIN_impDPROD + call fooD(DPROD(R1,R2)) +c FFEINTRIN_impDSIGN + call fooD(DSIGN(D1,D2)) +c FFEINTRIN_impDSIN + call fooD(DSIN(D1)) +c FFEINTRIN_impDSINH + call fooD(DSINH(D1)) +c FFEINTRIN_impDSQRT + call fooD(DSQRT(D1)) +c FFEINTRIN_impDTAN + call fooD(DTAN(D1)) +c FFEINTRIN_impDTANH + call fooD(DTANH(D1)) +c FFEINTRIN_impEXP + call fooR(EXP(R1)) +c FFEINTRIN_impIABS + call fooI(IABS(I1)) +c FFEINTRIN_impICHAR + call fooI(ICHAR(A1)) +c FFEINTRIN_impIDIM + call fooI(IDIM(I1,I2)) +c FFEINTRIN_impIDNINT + call fooI(IDNINT(D1)) +c FFEINTRIN_impINDEX + call fooI(INDEX(A1,A2)) +c FFEINTRIN_impISIGN + call fooI(ISIGN(I1,I2)) +c FFEINTRIN_impLEN + call fooI(LEN(A1)) +c FFEINTRIN_impLGE + call fooL(LGE(A1,A2)) +c FFEINTRIN_impLGT + call fooL(LGT(A1,A2)) +c FFEINTRIN_impLLE + call fooL(LLE(A1,A2)) +c FFEINTRIN_impLLT + call fooL(LLT(A1,A2)) +c FFEINTRIN_impMAX0 + call fooI(MAX0(I1,I2)) +c FFEINTRIN_impMAX1 + call fooI(MAX1(R1,R2)) +c FFEINTRIN_impMIN0 + call fooI(MIN0(I1,I2)) +c FFEINTRIN_impMIN1 + call fooI(MIN1(R1,R2)) +c FFEINTRIN_impMOD + call fooI(MOD(I1,I2)) +c FFEINTRIN_impNINT + call fooI(NINT(R1)) +c FFEINTRIN_impSIGN + call fooR(SIGN(R1,R2)) +c FFEINTRIN_impSIN + call fooR(SIN(R1)) +c FFEINTRIN_impSINH + call fooR(SINH(R1)) +c FFEINTRIN_impSQRT + call fooR(SQRT(R1)) +c FFEINTRIN_impTAN + call fooR(TAN(R1)) +c FFEINTRIN_impTANH + call fooR(TANH(R1)) +c FFEINTRIN_imp_CMPLX_C + call fooC(cmplx(C1,C2)) +c FFEINTRIN_imp_CMPLX_D + call fooZ(cmplx(D1,D2)) +c FFEINTRIN_imp_CMPLX_I + call fooC(cmplx(I1,I2)) +c FFEINTRIN_imp_CMPLX_R + call fooC(cmplx(R1,R2)) +c FFEINTRIN_imp_DBLE_C + call fooD(dble(C1)) +c FFEINTRIN_imp_DBLE_D + call fooD(dble(D1)) +c FFEINTRIN_imp_DBLE_I + call fooD(dble(I1)) +c FFEINTRIN_imp_DBLE_R + call fooD(dble(R1)) +c FFEINTRIN_imp_INT_C + call fooI(int(C1)) +c FFEINTRIN_imp_INT_D + call fooI(int(D1)) +c FFEINTRIN_imp_INT_I + call fooI(int(I1)) +c FFEINTRIN_imp_INT_R + call fooI(int(R1)) +c FFEINTRIN_imp_REAL_C + call fooR(real(C1)) +c FFEINTRIN_imp_REAL_D + call fooR(real(D1)) +c FFEINTRIN_imp_REAL_I + call fooR(real(I1)) +c FFEINTRIN_imp_REAL_R + call fooR(real(R1)) +c +c FFEINTRIN_imp_INT_D: +c +c FFEINTRIN_specIDINT + call fooI(IDINT(D1)) +c +c FFEINTRIN_imp_INT_R: +c +c FFEINTRIN_specIFIX + call fooI(IFIX(R1)) +c FFEINTRIN_specINT + call fooI(INT(R1)) +c +c FFEINTRIN_imp_REAL_D: +c +c FFEINTRIN_specSNGL + call fooR(SNGL(D1)) +c +c FFEINTRIN_imp_REAL_I: +c +c FFEINTRIN_specFLOAT + call fooR(FLOAT(I1)) +c FFEINTRIN_specREAL + call fooR(REAL(I1)) +c + end +-------- (end input file to f2c) + +-------- (begin output from providing above input file as input to: +-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ +-------- -e "s:^#.*$::g"') + +// -- translated by f2c (version 19950223). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +// + + +// f2c.h -- Standard Fortran to C header file // + +/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // + + + + +// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // +// we assume short, float are OK // +typedef long int // long int // integer; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int // long int // logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +// typedef long long longint; // // system-dependent // + + + + +// Extern is for use with -E // + + + + +// I/O stuff // + + + + + + + + +typedef long int // int or long int // flag; +typedef long int // int or long int // ftnlen; +typedef long int // int or long int // ftnint; + + +//external read, write// +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +//internal read, write// +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +//open// +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +//close// +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +//rewind, backspace, endfile// +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +// inquire // +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; //parameters in standard's order// + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + + + +union Multitype { // for multiple entry points // + integer1 g; + shortint h; + integer i; + // longint j; // + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +typedef long Long; // No longer used; formerly in Namelist // + +struct Vardesc { // for Namelist // + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + + + + + + + + +// procedure parameter types for -A and -C++ // + + + + +typedef int // Unknown procedure type // (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef // Complex // void (*C_fp)(); +typedef // Double Complex // void (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef // Character // void (*H_fp)(); +typedef // Subroutine // int (*S_fp)(); + +// E_fp is for real functions when -R is not specified // +typedef void C_f; // complex function // +typedef void H_f; // character function // +typedef void Z_f; // double complex function // +typedef doublereal E_f; // real function with -R not specified // + +// undef any lower-case symbols that your C compiler predefines, e.g.: // + + +// (No such symbols should be defined in a strict ANSI C compiler. + We can avoid trouble with f2c-translated code by using + gcc -ansi [-traditional].) // + + + + + + + + + + + + + + + + + + + + + + + +// Main program // MAIN__() +{ + // System generated locals // + integer i__1; + real r__1, r__2; + doublereal d__1, d__2; + complex q__1; + doublecomplex z__1, z__2, z__3; + logical L__1; + char ch__1[1]; + + // Builtin functions // + void c_div(); + integer pow_ii(); + double pow_ri(), pow_di(); + void pow_ci(); + double pow_dd(); + void pow_zz(); + double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), + asin(), atan(), atan2(), c_abs(); + void c_cos(), c_exp(), c_log(), r_cnjg(); + double cos(), cosh(); + void c_sin(), c_sqrt(); + double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), + d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); + integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); + logical l_ge(), l_gt(), l_le(), l_lt(); + integer i_nint(); + double r_sign(); + + // Local variables // + extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), + fool_(), fooz_(), getem_(); + static char a1[10], a2[10]; + static complex c1, c2; + static doublereal d1, d2; + static integer i1, i2; + static real r1, r2; + + + getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); +// / // + i__1 = i1 / i2; + fooi_(&i__1); + r__1 = r1 / i1; + foor_(&r__1); + d__1 = d1 / i1; + food_(&d__1); + d__1 = (doublereal) i1; + q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; + fooc_(&q__1); + r__1 = r1 / r2; + foor_(&r__1); + d__1 = r1 / d1; + food_(&d__1); + d__1 = d1 / d2; + food_(&d__1); + d__1 = d1 / r1; + food_(&d__1); + c_div(&q__1, &c1, &c2); + fooc_(&q__1); + q__1.r = c1.r / r1, q__1.i = c1.i / r1; + fooc_(&q__1); + z__1.r = c1.r / d1, z__1.i = c1.i / d1; + fooz_(&z__1); +// ** // + i__1 = pow_ii(&i1, &i2); + fooi_(&i__1); + r__1 = pow_ri(&r1, &i1); + foor_(&r__1); + d__1 = pow_di(&d1, &i1); + food_(&d__1); + pow_ci(&q__1, &c1, &i1); + fooc_(&q__1); + d__1 = (doublereal) r1; + d__2 = (doublereal) r2; + r__1 = pow_dd(&d__1, &d__2); + foor_(&r__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d__2, &d1); + food_(&d__1); + d__1 = pow_dd(&d1, &d2); + food_(&d__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d1, &d__2); + food_(&d__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = c2.r, z__3.i = c2.i; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = r1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = d1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + fooz_(&z__1); +// FFEINTRIN_impABS // + r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; + foor_(&r__1); +// FFEINTRIN_impACOS // + r__1 = acos(r1); + foor_(&r__1); +// FFEINTRIN_impAIMAG // + r__1 = r_imag(&c1); + foor_(&r__1); +// FFEINTRIN_impAINT // + r__1 = r_int(&r1); + foor_(&r__1); +// FFEINTRIN_impALOG // + r__1 = log(r1); + foor_(&r__1); +// FFEINTRIN_impALOG10 // + r__1 = r_lg10(&r1); + foor_(&r__1); +// FFEINTRIN_impAMAX0 // + r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMAX1 // + r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN0 // + r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN1 // + r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMOD // + r__1 = r_mod(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impANINT // + r__1 = r_nint(&r1); + foor_(&r__1); +// FFEINTRIN_impASIN // + r__1 = asin(r1); + foor_(&r__1); +// FFEINTRIN_impATAN // + r__1 = atan(r1); + foor_(&r__1); +// FFEINTRIN_impATAN2 // + r__1 = atan2(r1, r2); + foor_(&r__1); +// FFEINTRIN_impCABS // + r__1 = c_abs(&c1); + foor_(&r__1); +// FFEINTRIN_impCCOS // + c_cos(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCEXP // + c_exp(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCHAR // + *(unsigned char *)&ch__1[0] = i1; + fooa_(ch__1, 1L); +// FFEINTRIN_impCLOG // + c_log(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCONJG // + r_cnjg(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCOS // + r__1 = cos(r1); + foor_(&r__1); +// FFEINTRIN_impCOSH // + r__1 = cosh(r1); + foor_(&r__1); +// FFEINTRIN_impCSIN // + c_sin(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCSQRT // + c_sqrt(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impDABS // + d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; + food_(&d__1); +// FFEINTRIN_impDACOS // + d__1 = acos(d1); + food_(&d__1); +// FFEINTRIN_impDASIN // + d__1 = asin(d1); + food_(&d__1); +// FFEINTRIN_impDATAN // + d__1 = atan(d1); + food_(&d__1); +// FFEINTRIN_impDATAN2 // + d__1 = atan2(d1, d2); + food_(&d__1); +// FFEINTRIN_impDCOS // + d__1 = cos(d1); + food_(&d__1); +// FFEINTRIN_impDCOSH // + d__1 = cosh(d1); + food_(&d__1); +// FFEINTRIN_impDDIM // + d__1 = d_dim(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDEXP // + d__1 = exp(d1); + food_(&d__1); +// FFEINTRIN_impDIM // + r__1 = r_dim(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impDINT // + d__1 = d_int(&d1); + food_(&d__1); +// FFEINTRIN_impDLOG // + d__1 = log(d1); + food_(&d__1); +// FFEINTRIN_impDLOG10 // + d__1 = d_lg10(&d1); + food_(&d__1); +// FFEINTRIN_impDMAX1 // + d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMIN1 // + d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMOD // + d__1 = d_mod(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDNINT // + d__1 = d_nint(&d1); + food_(&d__1); +// FFEINTRIN_impDPROD // + d__1 = (doublereal) r1 * r2; + food_(&d__1); +// FFEINTRIN_impDSIGN // + d__1 = d_sign(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDSIN // + d__1 = sin(d1); + food_(&d__1); +// FFEINTRIN_impDSINH // + d__1 = sinh(d1); + food_(&d__1); +// FFEINTRIN_impDSQRT // + d__1 = sqrt(d1); + food_(&d__1); +// FFEINTRIN_impDTAN // + d__1 = tan(d1); + food_(&d__1); +// FFEINTRIN_impDTANH // + d__1 = tanh(d1); + food_(&d__1); +// FFEINTRIN_impEXP // + r__1 = exp(r1); + foor_(&r__1); +// FFEINTRIN_impIABS // + i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; + fooi_(&i__1); +// FFEINTRIN_impICHAR // + i__1 = *(unsigned char *)a1; + fooi_(&i__1); +// FFEINTRIN_impIDIM // + i__1 = i_dim(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impIDNINT // + i__1 = i_dnnt(&d1); + fooi_(&i__1); +// FFEINTRIN_impINDEX // + i__1 = i_indx(a1, a2, 10L, 10L); + fooi_(&i__1); +// FFEINTRIN_impISIGN // + i__1 = i_sign(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impLEN // + i__1 = i_len(a1, 10L); + fooi_(&i__1); +// FFEINTRIN_impLGE // + L__1 = l_ge(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLGT // + L__1 = l_gt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLE // + L__1 = l_le(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLT // + L__1 = l_lt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impMAX0 // + i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMAX1 // + i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN0 // + i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN1 // + i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMOD // + i__1 = i1 % i2; + fooi_(&i__1); +// FFEINTRIN_impNINT // + i__1 = i_nint(&r1); + fooi_(&i__1); +// FFEINTRIN_impSIGN // + r__1 = r_sign(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impSIN // + r__1 = sin(r1); + foor_(&r__1); +// FFEINTRIN_impSINH // + r__1 = sinh(r1); + foor_(&r__1); +// FFEINTRIN_impSQRT // + r__1 = sqrt(r1); + foor_(&r__1); +// FFEINTRIN_impTAN // + r__1 = tan(r1); + foor_(&r__1); +// FFEINTRIN_impTANH // + r__1 = tanh(r1); + foor_(&r__1); +// FFEINTRIN_imp_CMPLX_C // + r__1 = c1.r; + r__2 = c2.r; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_D // + z__1.r = d1, z__1.i = d2; + fooz_(&z__1); +// FFEINTRIN_imp_CMPLX_I // + r__1 = (real) i1; + r__2 = (real) i2; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_R // + q__1.r = r1, q__1.i = r2; + fooc_(&q__1); +// FFEINTRIN_imp_DBLE_C // + d__1 = (doublereal) c1.r; + food_(&d__1); +// FFEINTRIN_imp_DBLE_D // + d__1 = d1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_I // + d__1 = (doublereal) i1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_R // + d__1 = (doublereal) r1; + food_(&d__1); +// FFEINTRIN_imp_INT_C // + i__1 = (integer) c1.r; + fooi_(&i__1); +// FFEINTRIN_imp_INT_D // + i__1 = (integer) d1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_I // + i__1 = i1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_R // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_imp_REAL_C // + r__1 = c1.r; + foor_(&r__1); +// FFEINTRIN_imp_REAL_D // + r__1 = (real) d1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_I // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_R // + r__1 = r1; + foor_(&r__1); + +// FFEINTRIN_imp_INT_D: // + +// FFEINTRIN_specIDINT // + i__1 = (integer) d1; + fooi_(&i__1); + +// FFEINTRIN_imp_INT_R: // + +// FFEINTRIN_specIFIX // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_specINT // + i__1 = (integer) r1; + fooi_(&i__1); + +// FFEINTRIN_imp_REAL_D: // + +// FFEINTRIN_specSNGL // + r__1 = (real) d1; + foor_(&r__1); + +// FFEINTRIN_imp_REAL_I: // + +// FFEINTRIN_specFLOAT // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_specREAL // + r__1 = (real) i1; + foor_(&r__1); + +} // MAIN__ // + +-------- (end output file from f2c) + +*/ +} + +#endif +/* For power (exponentiation) where right-hand operand is type INTEGER, + generate in-line code to do it the fast way (which, if the operand + is a constant, might just mean a series of multiplies). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_expr_power_integer_ (ffebld left, ffebld right) +{ + tree l = ffecom_expr (left); + tree r = ffecom_expr (right); + tree ltype = TREE_TYPE (l); + tree rtype = TREE_TYPE (r); + tree result = NULL_TREE; + + if (l == error_mark_node + || r == error_mark_node) + return error_mark_node; + + if (TREE_CODE (r) == INTEGER_CST) + { + int sgn = tree_int_cst_sgn (r); + + if (sgn == 0) + return convert (ltype, integer_one_node); + + if ((TREE_CODE (ltype) == INTEGER_TYPE) + && (sgn < 0)) + { + /* Reciprocal of integer is either 0, -1, or 1, so after + calculating that (which we leave to the back end to do + or not do optimally), don't bother with any multiplying. */ + + result = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL); + r = ffecom_1 (NEGATE_EXPR, + rtype, + r); + if ((TREE_INT_CST_LOW (r) & 1) == 0) + result = ffecom_1 (ABS_EXPR, rtype, + result); + } + + /* Generate appropriate series of multiplies, preceded + by divide if the exponent is negative. */ + + l = save_expr (l); + + if (sgn < 0) + { + l = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL); + r = ffecom_1 (NEGATE_EXPR, rtype, r); + assert (TREE_CODE (r) == INTEGER_CST); + + if (tree_int_cst_sgn (r) < 0) + { /* The "most negative" number. */ + r = ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node)); + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + } + + for (;;) + { + if (TREE_INT_CST_LOW (r) & 1) + { + if (result == NULL_TREE) + result = l; + else + result = ffecom_2 (MULT_EXPR, ltype, + result, + l); + } + + r = ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node); + if (integer_zerop (r)) + break; + assert (TREE_CODE (r) == INTEGER_CST); + + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + return result; + } + + /* Though rhs isn't a constant, in-line code cannot be expanded + while transforming dummies + because the back end cannot be easily convinced to generate + stores (MODIFY_EXPR), handle temporaries, and so on before + all the appropriate rtx's have been generated for things like + dummy args referenced in rhs -- which doesn't happen until + store_parm_decls() is called (expand_function_start, I believe, + does the actual rtx-stuffing of PARM_DECLs). + + So, in this case, let the caller generate the call to the + run-time-library function to evaluate the power for us. */ + + if (ffecom_transform_only_dummies_) + return NULL_TREE; + + /* Right-hand operand not a constant, expand in-line code to figure + out how to do the multiplies, &c. + + The returned expression is expressed this way in GNU C, where l and + r are the "inputs": + + ({ typeof (r) rtmp = r; + typeof (l) ltmp = l; + typeof (l) result; + + if (rtmp == 0) + result = 1; + else + { + if ((basetypeof (l) == basetypeof (int)) + && (rtmp < 0)) + { + result = ((typeof (l)) 1) / ltmp; + if ((ltmp < 0) && (((-rtmp) & 1) == 0)) + result = -result; + } + else + { + result = 1; + if ((basetypeof (l) != basetypeof (int)) + && (rtmp < 0)) + { + ltmp = ((typeof (l)) 1) / ltmp; + rtmp = -rtmp; + if (rtmp < 0) + { + rtmp = -(rtmp >> 1); + ltmp *= ltmp; + } + } + for (;;) + { + if (rtmp & 1) + result *= ltmp; + if ((rtmp >>= 1) == 0) + break; + ltmp *= ltmp; + } + } + } + result; + }) + + Note that some of the above is compile-time collapsable, such as + the first part of the if statements that checks the base type of + l against int. The if statements are phrased that way to suggest + an easy way to generate the if/else constructs here, knowing that + the back end should (and probably does) eliminate the resulting + dead code (either the int case or the non-int case), something + it couldn't do without the redundant phrasing, requiring explicit + dead-code elimination here, which would be kind of difficult to + read. */ + + { + tree rtmp; + tree ltmp; + tree basetypeof_l_is_int; + tree se; + + basetypeof_l_is_int + = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); + + se = expand_start_stmt_expr (); + ffecom_push_calltemps (); + + rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1, + TRUE); + ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, + TRUE); + result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, + TRUE); + + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + r)); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + l)); + expand_start_cond (ffecom_truth_value + (ffecom_2 (EQ_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_else (); + if (!integer_zerop (basetypeof_l_is_int)) + { + expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_2 (LT_EXPR, integer_type_node, + ltmp, + convert (ltype, + integer_zero_node)), + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_2 (BIT_AND_EXPR, + rtype, + ffecom_1 (NEGATE_EXPR, + rtype, + rtmp), + convert (rtype, + integer_one_node)), + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_1 (NEGATE_EXPR, + ltype, + result))); + expand_end_cond (); + expand_start_else (); + } + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_truth_value_invert + (basetypeof_l_is_int), + ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL))); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + rtmp))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_cond (); + expand_end_cond (); + expand_start_loop (1); + expand_start_cond (ffecom_truth_value + (ffecom_2 (BIT_AND_EXPR, rtype, + rtmp, + convert (rtype, integer_one_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_2 (MULT_EXPR, ltype, + result, + ltmp))); + expand_end_cond (); + expand_exit_loop_if_false (NULL, + ffecom_truth_value + (ffecom_modify (rtype, + rtmp, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_loop (); + expand_end_cond (); + if (!integer_zerop (basetypeof_l_is_int)) + expand_end_cond (); + expand_expr_stmt (result); + + ffecom_pop_calltemps (); + result = expand_end_stmt_expr (se); + TREE_SIDE_EFFECTS (result) = 1; + } + + return result; +} + +#endif +/* ffecom_expr_transform_ -- Transform symbols in expr + + ffebld expr; // FFE expression. + ffecom_expr_transform_ (expr); + + Recursive descent on expr while transforming any untransformed SYMTERs. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_expr_transform_ (ffebld expr) +{ + tree t; + ffesymbol s; + +tail_recurse: /* :::::::::::::::::::: */ + + if (expr == NULL) + return; + + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + t = ffesymbol_hook (s).decl_tree; + if ((t == NULL_TREE) + && ((ffesymbol_kind (s) != FFEINFO_kindNONE) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy, + DIMENSION expr? */ + } + break; /* Ok if (t == NULL) here. */ + + case FFEBLD_opITEM: + ffecom_expr_transform_ (ffebld_head (expr)); + expr = ffebld_trail (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + switch (ffebld_arity (expr)) + { + case 2: + ffecom_expr_transform_ (ffebld_left (expr)); + expr = ffebld_right (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + case 1: + expr = ffebld_left (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + return; +} + +#endif +/* Make a type based on info in live f2c.h file. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_f2c_make_type_ (tree *type, int tcode, char *name) +{ + switch (tcode) + { + case FFECOM_f2ccodeCHAR: + *type = make_signed_type (CHAR_TYPE_SIZE); + break; + + case FFECOM_f2ccodeSHORT: + *type = make_signed_type (SHORT_TYPE_SIZE); + break; + + case FFECOM_f2ccodeINT: + *type = make_signed_type (INT_TYPE_SIZE); + break; + + case FFECOM_f2ccodeLONG: + *type = make_signed_type (LONG_TYPE_SIZE); + break; + + case FFECOM_f2ccodeLONGLONG: + *type = make_signed_type (LONG_LONG_TYPE_SIZE); + break; + + case FFECOM_f2ccodeCHARPTR: + *type = build_pointer_type (DEFAULT_SIGNED_CHAR + ? signed_char_type_node + : unsigned_char_type_node); + break; + + case FFECOM_f2ccodeFLOAT: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeLONGDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeTWOREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node); + break; + + case FFECOM_f2ccodeTWODOUBLEREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node); + break; + + default: + assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL); + *type = error_mark_node; + return; + } + + pushdecl (build_decl (TYPE_DECL, + ffecom_get_invented_identifier ("__g77_f2c_%s", + name, 0), + *type)); +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +/* Set the f2c list-directed-I/O code for whatever (integral) type has the + given size. */ + +static void +ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, + int code) +{ + int j; + tree t; + + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + if (((t = ffecom_tree_type[bt][j]) != NULL_TREE) + && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size)) + { + assert (code != -1); + ffecom_f2c_typecode_[bt][j] = code; + code = -1; + } +} + +#endif +/* Finish up globals after doing all program units in file + + Need to handle only uninitialized COMMON areas. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffeglobal +ffecom_finish_global_ (ffeglobal global) +{ + tree cbtype; + tree cbt; + tree size; + + if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON) + return global; + + if (ffeglobal_common_init (global)) + return global; + + cbt = ffeglobal_hook (global); + if ((cbt == NULL_TREE) + || !ffeglobal_common_have_size (global)) + return global; /* No need to make common, never ref'd. */ + + suspend_momentary (); + + DECL_EXTERNAL (cbt) = 0; + + /* Give the array a size now. */ + + size = build_int_2 (ffeglobal_common_size (global), 0); + + cbtype = TREE_TYPE (cbt); + TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, + integer_one_node, + size); + if (!TREE_TYPE (size)) + TREE_TYPE (size) = TYPE_DOMAIN (cbtype); + layout_type (cbtype); + + cbt = start_decl (cbt, FALSE); + assert (cbt == ffeglobal_hook (global)); + + finish_decl (cbt, NULL_TREE, FALSE); + + return global; +} + +#endif +/* Finish up any untransformed symbols. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_finish_symbol_transform_ (ffesymbol s) +{ + if (s == NULL) + return s; + + /* It's easy to know to transform an untransformed symbol, to make sure + we put out debugging info for it. But COMMON variables, unlike + EQUIVALENCE ones, aren't given declarations in addition to the + tree expressions that specify offsets, because COMMON variables + can be referenced in the outer scope where only dummy arguments + (PARM_DECLs) should really be seen. To be safe, just don't do any + VAR_DECLs for COMMON variables when we transform them for real + use, and therefore we do all the VAR_DECL creating here. */ + + if ((ffesymbol_hook (s).decl_tree == NULL_TREE) + && ((ffesymbol_kind (s) != FFEINFO_kindNONE) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))) + && (ffesymbol_where (s) != FFEINFO_whereDUMMY)) + /* Not transformed, and not CHARACTER*(*), and not a dummy + argument, which can happen only if the entry point names + it "rides in on" are all invalidated for other reasons. */ + s = ffecom_sym_transform_ (s); + + if ((ffesymbol_where (s) == FFEINFO_whereCOMMON) + && (ffesymbol_hook (s).decl_tree != error_mark_node)) + { +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + int yes = suspend_momentary (); + + /* This isn't working, at least for dbxout. The .s file looks + okay to me (burley), but in gdb 4.9 at least, the variables + appear to reside somewhere outside of the common area, so + it doesn't make sense to mislead anyone by generating the info + on those variables until this is fixed. NOTE: Same problem + with EQUIVALENCE, sadly...see similar #if later. */ + ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)), + ffesymbol_storage (s)); + + resume_momentary (yes); +#endif + } + + return s; +} + +#endif +/* Append underscore(s) to name before calling get_identifier. "us" + is nonzero if the name already contains an underscore and thus + needs two underscores appended. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_appended_identifier_ (char us, char *name) +{ + int i; + char *newname; + tree id; + + newname = xmalloc ((i = strlen (name)) + 1 + + ffe_is_underscoring () + + us); + memcpy (newname, name, i); + newname[i] = '_'; + newname[i + us] = '_'; + newname[i + 1 + us] = '\0'; + id = get_identifier (newname); + + free (newname); + + return id; +} + +#endif +/* Decide whether to append underscore to name before calling + get_identifier. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_external_identifier_ (ffesymbol s) +{ + char us; + char *name = ffesymbol_text (s); + + /* If name is a built-in name, just return it as is. */ + + if (!ffe_is_underscoring () + || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0) +#if FFETARGET_isENFORCED_MAIN_NAME + || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0) +#else + || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) +#endif + || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0)) + return get_identifier (name); + + us = ffe_is_second_underscore () + ? (strchr (name, '_') != NULL) + : 0; + + return ffecom_get_appended_identifier_ (us, name); +} + +#endif +/* Decide whether to append underscore to internal name before calling + get_identifier. + + This is for non-external, top-function-context names only. Transform + identifier so it doesn't conflict with the transformed result + of using a _different_ external name. E.g. if "CALL FOO" is + transformed into "FOO_();", then the variable in "FOO_ = 3" + must be transformed into something that does not conflict, since + these two things should be independent. + + The transformation is as follows. If the name does not contain + an underscore, there is no possible conflict, so just return. + If the name does contain an underscore, then transform it just + like we transform an external identifier. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_identifier_ (char *name) +{ + /* If name does not contain an underscore, just return it as is. */ + + if (!ffe_is_underscoring () + || (strchr (name, '_') == NULL)) + return get_identifier (name); + + return ffecom_get_appended_identifier_ (ffe_is_second_underscore (), + name); +} + +#endif +/* ffecom_gen_sfuncdef_ -- Generate definition of statement function + + tree t; + ffesymbol s; // kindFUNCTION, whereIMMEDIATE. + t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s), + ffesymbol_kindtype(s)); + + Call after setting up containing function and getting trees for all + other symbols. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) +{ + ffebld expr = ffesymbol_sfexpr (s); + tree type; + tree func; + tree result; + bool charfunc = (bt == FFEINFO_basictypeCHARACTER); + static bool recurse = FALSE; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + ffecom_nested_entry_ = s; + + /* For now, we don't have a handy pointer to where the sfunc is actually + defined, though that should be easy to add to an ffesymbol. (The + token/where info available might well point to the place where the type + of the sfunc is declared, especially if that precedes the place where + the sfunc itself is defined, which is typically the case.) We should + put out a null pointer rather than point somewhere wrong, but I want to + see how it works at this point. */ + + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + + /* Pretransform the expression so any newly discovered things belong to the + outer program unit, not to the statement function. */ + + ffecom_expr_transform_ (expr); + + /* Make sure no recursive invocation of this fn (a specific case of failing + to pretransform an sfunc's expression, i.e. where its expression + references another untransformed sfunc) happens. */ + + assert (!recurse); + recurse = TRUE; + + yes = suspend_momentary (); + + push_f_function_context (); + + ffecom_push_calltemps (); + + if (charfunc) + type = void_type_node; + else + { + type = ffecom_tree_type[bt][kt]; + if (type == NULL_TREE) + type = integer_type_node; /* _sym_exec_transition reports + error. */ + } + + start_function (ffecom_get_identifier_ (ffesymbol_text (s)), + build_function_type (type, NULL_TREE), + 1, /* nested/inline */ + 0); /* TREE_PUBLIC */ + + /* We don't worry about COMPLEX return values here, because this is + entirely internal to our code, and gcc has the ability to return COMPLEX + directly as a value. */ + + yes = suspend_momentary (); + + if (charfunc) + { /* Prepend arg for where result goes. */ + tree type; + + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + } + else + result = NULL_TREE; /* Not ref'd if !charfunc. */ + + ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE); + + resume_momentary (yes); + + store_parm_decls (0); + + ffecom_start_compstmt_ (); + + if (expr != NULL) + { + if (charfunc) + { + ffetargetCharacterSize sz = ffesymbol_size (s); + tree result_length; + + result_length = build_int_2 (sz, 0); + TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; + + ffecom_let_char_ (result, result_length, sz, expr); + expand_null_return (); + } + else + expand_return (ffecom_modify (NULL_TREE, + DECL_RESULT (current_function_decl), + ffecom_expr (expr))); + + clear_momentary (); + } + + ffecom_end_compstmt_ (); + + func = current_function_decl; + finish_function (1); + + ffecom_pop_calltemps (); + + pop_f_function_context (); + + resume_momentary (yes); + + recurse = FALSE; + + lineno = old_lineno; + input_filename = old_input_filename; + + ffecom_nested_entry_ = NULL; + + return func; +} + +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static char * +ffecom_gfrt_args_ (ffecomGfrt ix) +{ + return ffecom_gfrt_argstring_[ix]; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_gfrt_tree_ (ffecomGfrt ix) +{ + if (ffecom_gfrt_[ix] == NULL_TREE) + ffecom_make_gfrt_ (ix); + + return ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])), + ffecom_gfrt_[ix]); +} + +#endif +/* Return initialize-to-zero expression for this VAR_DECL. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_init_zero_ (tree decl) +{ + tree init; + int incremental = TREE_STATIC (decl); + tree type = TREE_TYPE (decl); + + if (incremental) + { + int momentary = suspend_momentary (); + push_obstacks_nochange (); + if (TREE_PERMANENT (decl)) + end_temporary_allocation (); + make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0); + assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); + pop_obstacks (); + resume_momentary (momentary); + } + + push_momentary (); + + if ((TREE_CODE (type) != ARRAY_TYPE) + && (TREE_CODE (type) != RECORD_TYPE) + && (TREE_CODE (type) != UNION_TYPE) + && !incremental) + init = convert (type, integer_zero_node); + else if (!incremental) + { + int momentary = suspend_momentary (); + + init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE); + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; + + resume_momentary (momentary); + } + else + { + int momentary = suspend_momentary (); + + assemble_zeros (int_size_in_bytes (type)); + init = error_mark_node; + + resume_momentary (momentary); + } + + pop_momentary_nofree (); + + return init; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, + tree *maybe_tree) +{ + tree expr_tree; + tree length_tree; + + switch (ffebld_op (arg)) + { + case FFEBLD_opCONTER: /* For F90, check 0-length. */ + if (ffetarget_length_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + + *maybe_tree = integer_one_node; + expr_tree = build_int_2 (*ffetarget_text_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))), + 0); + TREE_TYPE (expr_tree) = tree_type; + return expr_tree; + + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + ffecom_push_calltemps (); + ffecom_char_args_ (&expr_tree, &length_tree, arg); + ffecom_pop_calltemps (); + + if ((expr_tree == error_mark_node) + || (length_tree == error_mark_node)) + { + *maybe_tree = error_mark_node; + return error_mark_node; + } + + if (integer_zerop (length_tree)) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + + expr_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree); + expr_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree, + integer_one_node); + expr_tree = convert (tree_type, expr_tree); + + if (TREE_CODE (length_tree) == INTEGER_CST) + *maybe_tree = integer_one_node; + else /* Must check length at run time. */ + *maybe_tree + = ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + length_tree, + ffecom_f2c_ftnlen_zero_node)); + return expr_tree; + + case FFEBLD_opPAREN: + case FFEBLD_opCONVERT: + if (ffeinfo_size (ffebld_info (arg)) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + maybe_tree); + + case FFEBLD_opCONCATENATE: + { + tree maybe_left; + tree maybe_right; + tree expr_left; + tree expr_right; + + expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + &maybe_left); + expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg), + &maybe_right); + *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + maybe_left, + maybe_right); + expr_tree = ffecom_3 (COND_EXPR, tree_type, + maybe_left, + expr_left, + expr_right); + return expr_tree; + } + + default: + assert ("bad op in ICHAR" == NULL); + return error_mark_node; + } +} + +#endif +/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN()) + + tree length_arg; + ffebld expr; + length_arg = ffecom_intrinsic_len_ (expr); + + Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF + subexpressions by constructing the appropriate tree for the + length-of-character-text argument in a calling sequence. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_intrinsic_len_ (ffebld expr) +{ + ffetargetCharacter1 val; + tree length; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + val = ffebld_constant_character1 (ffebld_conter (expr)); + length = build_int_2 (ffetarget_length_character1 (val), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; + + case FFEBLD_opSYMTER: + { + ffesymbol s = ffebld_symter (expr); + tree item; + + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (ffesymbol_kind (s) == FFEINFO_kindENTITY) + { + if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) + length = ffesymbol_hook (s).length_tree; + else + { + length = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + } + } + else if (item == error_mark_node) + length = error_mark_node; + else /* FFEINFO_kindFUNCTION: */ + length = NULL_TREE; + } + break; + + case FFEBLD_opARRAYREF: + length = ffecom_intrinsic_len_ (ffebld_left (expr)); + break; + + case FFEBLD_opSUBSTR: + { + ffebld start; + ffebld end; + ffebld thing = ffebld_right (expr); + tree start_tree; + tree end_tree; + + assert (ffebld_op (thing) == FFEBLD_opITEM); + start = ffebld_head (thing); + thing = ffebld_trail (thing); + assert (ffebld_trail (thing) == NULL); + end = ffebld_head (thing); + + length = ffecom_intrinsic_len_ (ffebld_left (expr)); + + if (length == error_mark_node) + break; + + if (start == NULL) + { + if (end == NULL) + ; + else + { + length = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + } + } + else + { + start_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (start)); + + if (start_tree == error_mark_node) + { + length = error_mark_node; + break; + } + + if (end == NULL) + { + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + length, + start_tree)); + } + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + length = error_mark_node; + break; + } + + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + end_tree, start_tree)); + } + } + } + break; + + case FFEBLD_opCONCATENATE: + length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_intrinsic_len_ (ffebld_left (expr)), + ffecom_intrinsic_len_ (ffebld_right (expr))); + break; + + case FFEBLD_opFUNCREF: + case FFEBLD_opCONVERT: + length = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; + + default: + assert ("bad op for single char arg expr" == NULL); + length = ffecom_f2c_ftnlen_zero_node; + break; + } + + assert (length != NULL_TREE); + + return length; +} + +#endif +/* ffecom_let_char_ -- Do assignment stuff for character type + + tree dest_tree; // destination (ADDR_EXPR) + tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL)) + ffetargetCharacterSize dest_size; // length + ffebld source; // source expression + ffecom_let_char_(dest_tree,dest_length,dest_size,source); + + Generates code to do the assignment. Used by ordinary assignment + statement handler ffecom_let_stmt and by statement-function + handler to generate code for a statement function. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_let_char_ (tree dest_tree, tree dest_length, + ffetargetCharacterSize dest_size, ffebld source) +{ + ffecomConcatList_ catlist; + tree source_length; + tree source_tree; + tree expr_tree; + + if ((dest_tree == error_mark_node) + || (dest_length == error_mark_node)) + return; + + assert (dest_tree != NULL_TREE); + assert (dest_length != NULL_TREE); + + /* Source might be an opCONVERT, which just means it is a different size + than the destination. Since the underlying implementation here handles + that (directly or via the s_copy or s_cat run-time-library functions), + we don't need the "convenience" of an opCONVERT that tells us to + truncate or blank-pad, particularly since the resulting implementation + would probably be slower than otherwise. */ + + while (ffebld_op (source) == FFEBLD_opCONVERT) + source = ffebld_left (source); + + catlist = ffecom_concat_list_new_ (source, dest_size); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + ffecom_concat_list_kill_ (catlist); + source_tree = null_pointer_node; + source_length = ffecom_f2c_ftnlen_zero_node; + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + + return; + + case 1: /* The (fairly) easy case. */ + ffecom_char_args_ (&source_tree, &source_length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (source_tree != NULL_TREE); + assert (source_length != NULL_TREE); + + if ((source_tree == error_mark_node) + || (source_length == error_mark_node)) + return; + + if (dest_size == 1) + { + dest_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree); + dest_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree, + integer_one_node); + source_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree); + source_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree, + integer_one_node); + + expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree); + + expand_expr_stmt (expr_tree); + + return; + } + + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + + return; + + default: /* Must actually concatenate things. */ + break; + } + + /* Heavy-duty concatenation. */ + + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; + + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, + count, TRUE); + + for (i = 0; i < count; ++i) + { + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + return; + } + + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } + + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) + = build_tree_list (NULL_TREE, dest_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + } + + ffecom_concat_list_kill_ (catlist); +} + +#endif +/* ffecom_make_gfrt_ -- Make initial info for run-time routine + + ffecomGfrt ix; + ffecom_make_gfrt_(ix); + + Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL + for the indicated run-time routine (ix). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_make_gfrt_ (ffecomGfrt ix) +{ + tree t; + tree ttype; + + push_obstacks_nochange (); + end_temporary_allocation (); + + switch (ffecom_gfrt_type_[ix]) + { + case FFECOM_rttypeVOID_: + ttype = void_type_node; + break; + + case FFECOM_rttypeINT_: + ttype = integer_type_node; + break; + + case FFECOM_rttypeINTEGER_: + ttype = ffecom_f2c_integer_type_node; + break; + + case FFECOM_rttypeLONGINT_: + ttype = ffecom_f2c_longint_type_node; + break; + + case FFECOM_rttypeLOGICAL_: + ttype = ffecom_f2c_logical_type_node; + break; + + case FFECOM_rttypeREAL_F2C_: + ttype = ffecom_f2c_real_type_node; + break; + + case FFECOM_rttypeREAL_GNU_: + ttype = ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]; + break; + + case FFECOM_rttypeCOMPLEX_F2C_: + ttype = void_type_node; + break; + + case FFECOM_rttypeCOMPLEX_GNU_: + ttype = ffecom_f2c_complex_type_node; + break; + + case FFECOM_rttypeDOUBLE_: + ttype = double_type_node; + break; + + case FFECOM_rttypeDBLCMPLX_F2C_: + ttype = void_type_node; + break; + + case FFECOM_rttypeDBLCMPLX_GNU_: + ttype = ffecom_f2c_doublecomplex_type_node; + break; + + case FFECOM_rttypeCHARACTER_: + ttype = void_type_node; + break; + + default: + ttype = NULL; + assert ("bad rttype" == NULL); + break; + } + + ttype = build_function_type (ttype, NULL_TREE); + t = build_decl (FUNCTION_DECL, + get_identifier (ffecom_gfrt_name_[ix]), + ttype); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; + + t = start_decl (t, TRUE); + + finish_decl (t, NULL_TREE, TRUE); + + resume_temporary_allocation (); + pop_obstacks (); + + ffecom_gfrt_[ix] = t; +} + +#endif +/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) +{ + ffesymbol s = ffestorag_symbol (st); + + if (ffesymbol_namelisted (s)) + ffecom_member_namelisted_ = TRUE; +} + +#endif +/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare + the member so debugger will see it. Otherwise nobody should be + referencing the member. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING +static void +ffecom_member_phase2_ (ffestorag mst, ffestorag st) +{ + ffesymbol s; + tree t; + tree mt; + tree type; + + if ((mst == NULL) + || ((mt = ffestorag_hook (mst)) == NULL) + || (mt == error_mark_node)) + return; + + if ((st == NULL) + || ((s = ffestorag_symbol (st)) == NULL)) + return; + + type = ffecom_type_localvar_ (s, + ffesymbol_basictype (s), + ffesymbol_kindtype (s)); + if (type == error_mark_node) + return; + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); + + TREE_STATIC (t) = TREE_STATIC (mt); + DECL_INITIAL (t) = NULL_TREE; + TREE_ASM_WRITTEN (t) = 1; + + DECL_RTL (t) + = gen_rtx (MEM, TYPE_MODE (type), + plus_constant (XEXP (DECL_RTL (mt), 0), + ffestorag_modulo (mst) + + ffestorag_offset (st) + - ffestorag_offset (mst))); + + t = start_decl (t, FALSE); + + finish_decl (t, NULL_TREE, FALSE); +} + +#endif +#endif +/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order + + Ignores STAR (alternate-return) dummies. All other get exec-transitioned + (which generates their trees) and then their trees get push_parm_decl'd. + + The second arg is TRUE if the dummies are for a statement function, in + which case lengths are not pushed for character arguments (since they are + always known by both the caller and the callee, though the code allows + for someday permitting CHAR*(*) stmtfunc dummies). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc) +{ + ffebld dummy; + ffebld dumlist; + ffesymbol s; + tree parm; + + ffecom_transform_only_dummies_ = TRUE; + + /* First push the parms corresponding to actual dummy "contents". */ + + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns. */ + + default: + break; + } + assert (ffebld_op (dummy) == FFEBLD_opSYMTER); + s = ffebld_symter (dummy); + parm = ffesymbol_hook (s).decl_tree; + if (parm == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + parm = ffesymbol_hook (s).decl_tree; + assert (parm != NULL_TREE); + } + if (parm != error_mark_node) + push_parm_decl (parm); + } + + /* Then, for CHARACTER dummies, push the parms giving their lengths. */ + + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns, they mean + NOTHING! */ + + default: + break; + } + s = ffebld_symter (dummy); + if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) + continue; /* Only looking for CHARACTER arguments. */ + if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE)) + continue; /* Stmtfunc arg with known size needs no + length param. */ + if (ffesymbol_kind (s) != FFEINFO_kindENTITY) + continue; /* Only looking for variables and arrays. */ + parm = ffesymbol_hook (s).length_tree; + assert (parm != NULL_TREE); + if (parm != error_mark_node) + push_parm_decl (parm); + } + + ffecom_transform_only_dummies_ = FALSE; +} + +#endif +/* ffecom_start_progunit_ -- Beginning of program unit + + Does GNU back end stuff necessary to teach it about the start of its + equivalent of a Fortran program unit. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_start_progunit_ () +{ + ffesymbol fn = ffecom_primary_entry_; + ffebld arglist; + tree id; /* Identifier (name) of function. */ + tree type; /* Type of function. */ + tree result; /* Result of function. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + ffeglobalType gt; + ffeglobalType egt = FFEGLOBAL_type; + bool charfunc; + bool cmplxfunc; + bool altentries = (ffecom_num_entrypoints_ != 0); + bool multi + = altentries + && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE); + bool main_program = FALSE; + int old_lineno = lineno; + char *old_input_filename = input_filename; + int yes; + + assert (fn != NULL); + assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); + + input_filename = ffesymbol_where_filename (fn); + lineno = ffesymbol_where_filelinenum (fn); + + /* c-parse.y indeed does call suspend_momentary and not only ignores the + return value, but also never calls resume_momentary, when starting an + outer function (see "fndef:", "setspecs:", and so on). So g77 does the + same thing. It shouldn't be a problem since start_function calls + temporary_allocation, but it might be necessary. If it causes a problem + here, then maybe there's a bug lurking in gcc. NOTE: This identical + comment appears twice in thist file. */ + + suspend_momentary (); + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindPROGRAM: + main_program = TRUE; + gt = FFEGLOBAL_typeMAIN; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindBLOCKDATA: + gt = FFEGLOBAL_typeBDATA; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindFUNCTION: + gt = FFEGLOBAL_typeFUNC; + egt = FFEGLOBAL_typeEXT; + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + if (bt == FFEINFO_basictypeNONE) + { + ffeimplic_establish_symbol (fn); + if (ffesymbol_funcresult (fn) != NULL) + ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + } + + if (multi) + charfunc = cmplxfunc = FALSE; + else if (bt == FFEINFO_basictypeCHARACTER) + charfunc = TRUE, cmplxfunc = FALSE; + else if ((bt == FFEINFO_basictypeCOMPLEX) + && ffesymbol_is_f2c (fn) + && !altentries) + charfunc = FALSE, cmplxfunc = TRUE; + else + charfunc = cmplxfunc = FALSE; + + if (multi || charfunc) + type = ffecom_tree_fun_type_void; + else if (ffesymbol_is_f2c (fn) && !altentries) + type = ffecom_tree_fun_type[bt][kt]; + else + type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + if ((type == NULL_TREE) + || (TREE_TYPE (type) == NULL_TREE)) + type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ + break; + + case FFEINFO_kindSUBROUTINE: + gt = FFEGLOBAL_typeSUBR; + egt = FFEGLOBAL_typeEXT; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + if (ffecom_is_altreturning_) + type = ffecom_tree_subr_type; + else + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + default: + assert ("say what??" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + gt = FFEGLOBAL_typeANY; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = error_mark_node; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + } + + if (altentries) + id = ffecom_get_invented_identifier ("__g77_masterfun_%s", + ffesymbol_text (fn), + 0); +#if FFETARGET_isENFORCED_MAIN + else if (main_program) + id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME); +#endif + else + id = ffecom_get_external_identifier_ (fn); + + start_function (id, + type, + 0, /* nested/inline */ + !altentries); /* TREE_PUBLIC */ + + if (!altentries + && ((g = ffesymbol_global (fn)) != NULL) + && ((ffeglobal_type (g) == gt) + || (ffeglobal_type (g) == egt))) + { + ffeglobal_set_hook (g, current_function_decl); + } + + yes = suspend_momentary (); + + /* Arg handling needs exec-transitioned ffesymbols to work with. But + exec-transitioning needs current_function_decl to be filled in. So we + do these things in two phases. */ + + if (altentries) + { /* 1st arg identifies which entrypoint. */ + ffecom_which_entrypoint_decl_ + = build_decl (PARM_DECL, + ffecom_get_invented_identifier ("__g77_%s", + "which_entrypoint", + 0), + integer_type_node); + push_parm_decl (ffecom_which_entrypoint_decl_); + } + + if (charfunc + || cmplxfunc + || multi) + { /* Arg for result (return value). */ + tree type; + tree length; + + if (charfunc) + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + else if (cmplxfunc) + type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; + else + type = ffecom_multi_type_node_; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + /* Make length arg _and_ enhance type info for CHAR arg itself. */ + + if (charfunc) + length = ffecom_char_enhance_arg_ (&type, fn); + else + length = NULL_TREE; /* Not ref'd if !charfunc. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + if (multi) + ffecom_multi_retval_ = result; + else + ffecom_func_result_ = result; + + if (charfunc) + { + push_parm_decl (length); + ffecom_func_length_ = length; + } + } + + if (ffecom_primary_entry_is_proc_) + { + if (altentries) + arglist = ffecom_master_arglist_; + else + arglist = ffesymbol_dummyargs (fn); + ffecom_push_dummy_decls_ (arglist, FALSE); + } + + resume_momentary (yes); + + store_parm_decls (main_program ? 1 : 0); + + ffecom_start_compstmt_ (); + + lineno = old_lineno; + input_filename = old_input_filename; + + /* This handles any symbols still untransformed, in case -g specified. + This used to be done in ffecom_finish_progunit, but it turns out to + be necessary to do it here so that statement functions are + expanded before code. But don't bother for BLOCK DATA. */ + + if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + ffesymbol_drive (ffecom_finish_symbol_transform_); +} + +#endif +/* ffecom_sym_transform_ -- Transform FFE sym into backend sym + + ffesymbol s; + ffecom_sym_transform_(s); + + The ffesymbol_hook info for s is updated with appropriate backend info + on the symbol. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_sym_transform_ (ffesymbol s) +{ + tree t; /* Transformed thingy. */ + tree tlen; /* Length if CHAR*(*). */ + bool addr; /* Is t the address of the thingy? */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + if (ffesymbol_sfdummyparent (s) == NULL) + { + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); + + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } + + bt = ffeinfo_basictype (ffebld_info (s)); + kt = ffeinfo_kindtype (ffebld_info (s)); + + t = NULL_TREE; + tlen = NULL_TREE; + addr = FALSE; + + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindNONE: + switch (ffesymbol_where (s)) + { + case FFEINFO_whereDUMMY: /* Subroutine or function. */ + assert (ffecom_transform_only_dummies_); + + /* Before 0.4, this could be ENTITY/DUMMY, but see + ffestu_sym_end_transition -- no longer true (in particular, if + it could be an ENTITY, it _will_ be made one, so that + possibility won't come through here). So we never make length + arg for CHARACTER type. */ + + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_ptr_to_subr_type); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; + + case FFEINFO_whereGLOBAL: /* Subroutine or function. */ + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); /* Assume subr. */ + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + default: + assert ("NONE where unexpected" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + break; + } + break; + + case FFEINFO_kindENTITY: + switch (ffeinfo_where (ffesymbol_info (s))) + { + + case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */ + assert (!ffecom_transform_only_dummies_); + t = error_mark_node; /* Shouldn't ever see this in expr. */ + break; + + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + + { + ffestorag st = ffesymbol_storage (s); + tree type; + + if ((st != NULL) + && (ffestorag_size (st) == 0)) + { + t = error_mark_node; + break; + } + + yes = suspend_momentary (); + type = ffecom_type_localvar_ (s, bt, kt); + resume_momentary (yes); + + if (type == error_mark_node) + { + t = error_mark_node; + break; + } + + if ((st != NULL) + && (ffestorag_parent (st) != NULL)) + { /* Child of EQUIVALENCE parent. */ + ffestorag est; + tree et; + int yes; + ffetargetOffset offset; + + est = ffestorag_parent (st); + ffecom_transform_equiv_ (est); + + et = ffestorag_hook (est); + assert (et != NULL_TREE); + + if (! TREE_STATIC (et)) + put_var_into_stack (et); + + yes = suspend_momentary (); + + offset = ffestorag_modulo (est) + + ffestorag_offset (ffesymbol_storage (s)) + - ffestorag_offset (est); + + ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset); + + /* (t_type *) (((char *) &et) + offset) */ + + t = convert (string_type_node, /* (char *) */ + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (et)), + et)); + t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), + t, + build_int_2 (offset, 0)); + t = convert (build_pointer_type (type), + t); + + addr = TRUE; + + resume_momentary (yes); + } + else + { + tree initexpr; + bool init = ffesymbol_is_init (s); + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); + + if (init + || ffesymbol_namelisted (s) +#ifdef FFECOM_sizeMAXSTACKITEM + || ((st != NULL) + && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ + != FFEINFO_kindBLOCKDATA) + && (ffesymbol_is_save (s) || ffe_is_saveall ()))) + TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE); + else + TREE_STATIC (t) = 0; /* No need to make static. */ + + if (init || ffe_is_init_local_zero ()) + DECL_INITIAL (t) = error_mark_node; + + /* Keep -Wunused from complaining about var if it + is used as sfunc arg or DATA implied-DO. */ + if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG) + DECL_IN_SYSTEM_HEADER (t) = 1; + + t = start_decl (t, FALSE); + + if (init) + { + if (ffesymbol_init (s) != NULL) + initexpr = ffecom_expr (ffesymbol_init (s)); + else + initexpr = ffecom_init_zero_ (t); + } + else if (ffe_is_init_local_zero ()) + initexpr = ffecom_init_zero_ (t); + else + initexpr = NULL_TREE; /* Not ref'd if !init. */ + + finish_decl (t, initexpr, FALSE); + + if ((st != NULL) && (DECL_SIZE (t) != error_mark_node)) + { + tree size_tree; + + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (t), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st)); + } + + resume_momentary (yes); + } + } + break; + + case FFEINFO_whereRESULT: + assert (!ffecom_transform_only_dummies_); + + if (bt == FFEINFO_basictypeCHARACTER) + { /* Result is already in list of dummies, use + it (& length). */ + t = ffecom_func_result_; + tlen = ffecom_func_length_; + addr = TRUE; + break; + } + if ((ffecom_num_entrypoints_ == 0) + && (bt == FFEINFO_basictypeCOMPLEX) + && (ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Result is already in list of dummies, use + it. */ + t = ffecom_func_result_; + addr = TRUE; + break; + } + if (ffecom_func_result_ != NULL_TREE) + { + t = ffecom_func_result_; + break; + } + if ((ffecom_num_entrypoints_ != 0) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE)) + { + yes = suspend_momentary (); + + assert (ffecom_multi_retval_ != NULL_TREE); + t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_, + ffecom_multi_retval_); + t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt], + t, ffecom_multi_fields_[bt][kt]); + + resume_momentary (yes); + break; + } + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_type[bt][kt]); + TREE_STATIC (t) = 0; /* Put result on stack. */ + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + ffecom_func_result_ = t; + + resume_momentary (yes); + break; + + case FFEINFO_whereDUMMY: + { + tree type; + ffebld dl; + ffebld dim; + tree low; + tree high; + tree old_sizes; + bool adjustable = FALSE; /* Conditionally adjustable? */ + + type = ffecom_tree_type[bt][kt]; + if (ffesymbol_sfdummyparent (s) != NULL) + { + if (current_function_decl == ffecom_outer_function_decl_) + { /* Exec transition before sfunc + context; get it later. */ + break; + } + t = ffecom_get_identifier_ (ffesymbol_text + (ffesymbol_sfdummyparent (s))); + } + else + t = ffecom_get_identifier_ (ffesymbol_text (s)); + + assert (ffecom_transform_only_dummies_); + + old_sizes = get_pending_sizes (); + put_pending_sizes (old_sizes); + + if (bt == FFEINFO_basictypeCHARACTER) + tlen = ffecom_char_enhance_arg_ (&type, s); + type = ffecom_check_size_overflow_ (s, type, TRUE); + + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; + + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (dim)); + assert (ffebld_right (dim) != NULL); + if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR) + || ffecom_doing_entry_) + /* Used to just do high=low. But for ffecom_tree_ + canonize_ref_, it probably is important to correctly + assess the size. E.g. given COMPLEX C(*),CFUNC and + C(2)=CFUNC(C), overlap can happen, while it can't + for, say, C(1)=CFUNC(C(2)). */ + high = convert (TREE_TYPE (low), + TYPE_MAX_VALUE (TREE_TYPE (low))); + else + high = ffecom_expr (ffebld_right (dim)); + + /* Determine whether array is conditionally adjustable, + to decide whether back-end magic is needed. + + Normally the front end uses the back-end function + variable_size to wrap SAVE_EXPR's around expressions + affecting the size/shape of an array so that the + size/shape info doesn't change during execution + of the compiled code even though variables and + functions referenced in those expressions might. + + variable_size also makes sure those saved expressions + get evaluated immediately upon entry to the + compiled procedure -- the front end normally doesn't + have to worry about that. + + However, there is a problem with this that affects + g77's implementation of entry points, and that is + that it is _not_ true that each invocation of the + compiled procedure is permitted to evaluate + array size/shape info -- because it is possible + that, for some invocations, that info is invalid (in + which case it is "promised" -- i.e. a violation of + the Fortran standard -- that the compiled code + won't reference the array or its size/shape + during that particular invocation). + + To phrase this in C terms, consider this gcc function: + + void foo (int *n, float (*a)[*n]) + { + // a is "pointer to array ...", fyi. + } + + Suppose that, for some invocations, it is permitted + for a caller of foo to do this: + + foo (NULL, NULL); + + Now the _written_ code for foo can take such a call + into account by either testing explicitly for whether + (a == NULL) || (n == NULL) -- presumably it is + not permitted to reference *a in various fashions + if (n == NULL) I suppose -- or it can avoid it by + looking at other info (other arguments, static/global + data, etc.). + + However, this won't work in gcc 2.5.8 because it'll + automatically emit the code to save the "*n" + expression, which'll yield a NULL dereference for + the "foo (NULL, NULL)" call, something the code + for foo cannot prevent. + + g77 definitely needs to avoid executing such + code anytime the pointer to the adjustable array + is NULL, because even if its bounds expressions + don't have any references to possible "absent" + variables like "*n" -- say all variable references + are to COMMON variables, i.e. global (though in C, + local static could actually make sense) -- the + expressions could yield other run-time problems + for allowably "dead" values in those variables. + + For example, let's consider a more complicated + version of foo: + + extern int i; + extern int j; + + void foo (float (*a)[i/j]) + { + ... + } + + The above is (essentially) quite valid for Fortran + but, again, for a call like "foo (NULL);", it is + permitted for i and j to be undefined when the + call is made. If j happened to be zero, for + example, emitting the code to evaluate "i/j" + could result in a run-time error. + + Offhand, though I don't have my F77 or F90 + standards handy, it might even be valid for a + bounds expression to contain a function reference, + in which case I doubt it is permitted for an + implementation to invoke that function in the + Fortran case involved here (invocation of an + alternate ENTRY point that doesn't have the adjustable + array as one of its arguments). + + So, the code that the compiler would normally emit + to preevaluate the size/shape info for an + adjustable array _must not_ be executed at run time + in certain cases. Specifically, for Fortran, + the case is when the pointer to the adjustable + array == NULL. (For gnu-ish C, it might be nice + for the source code itself to specify an expression + that, if TRUE, inhibits execution of the code. Or + reverse the sense for elegance.) + + (Note that g77 could use a different test than NULL, + actually, since it happens to always pass an + integer to the called function that specifies which + entry point is being invoked. Hmm, this might + solve the next problem.) + + One way a user could, I suppose, write "foo" so + it works is to insert COND_EXPR's for the + size/shape info so the dangerous stuff isn't + actually done, as in: + + void foo (int *n, float (*a)[(a == NULL) ? 0 : *n]) + { + ... + } + + The next problem is that the front end needs to + be able to tell the back end about the array's + decl _before_ it tells it about the conditional + expression to inhibit evaluation of size/shape info, + as shown above. + + To solve this, the front end needs to be able + to give the back end the expression to inhibit + generation of the preevaluation code _after_ + it makes the decl for the adjustable array. + + Until then, the above example using the COND_EXPR + doesn't pass muster with gcc because the "(a == NULL)" + part has a reference to "a", which is still + undefined at that point. + + g77 will therefore use a different mechanism in the + meantime. */ + + if (!adjustable + && ((TREE_CODE (low) != INTEGER_CST) + || (TREE_CODE (high) != INTEGER_CST))) + adjustable = TRUE; + +#if 0 /* Old approach -- see below. */ + if (TREE_CODE (low) != INTEGER_CST) + low = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + low, + ffecom_integer_zero_node); + + if (TREE_CODE (high) != INTEGER_CST) + high = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + high, + ffecom_integer_zero_node); +#endif + + /* ~~~gcc/stor-layout.c/layout_type should do this, + probably. Fixes 950302-1.f. */ + + if (TREE_CODE (low) != INTEGER_CST) + low = variable_size (low); + + /* ~~~similarly, this fixes dumb0.f. The C front end + does this, which is why dumb0.c would work. */ + + if (TREE_CODE (high) != INTEGER_CST) + high = variable_size (high); + + type + = build_array_type + (type, + build_range_type (ffecom_integer_type_node, + low, high)); + type = ffecom_check_size_overflow_ (s, type, TRUE); + } + + if (type == error_mark_node) + { + t = error_mark_node; + break; + } + + if ((ffesymbol_sfdummyparent (s) == NULL) + || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) + { + type = build_pointer_type (type); + addr = TRUE; + } + + t = build_decl (PARM_DECL, t, type); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + + /* If this arg is present in every entry point's list of + dummy args, then we're done. */ + + if (ffesymbol_numentries (s) + == (ffecom_num_entrypoints_ + 1)) + break; + +#if 1 + + /* If variable_size in stor-layout has been called during + the above, then get_pending_sizes should have the + yet-to-be-evaluated saved expressions pending. + Make the whole lot of them get emitted, conditionally + on whether the array decl ("t" above) is not NULL. */ + + { + tree sizes = get_pending_sizes (); + tree tem; + + for (tem = sizes; + tem != old_sizes; + tem = TREE_CHAIN (tem)) + { + tree temv = TREE_VALUE (tem); + + if (sizes == tem) + sizes = temv; + else + sizes + = ffecom_2 (COMPOUND_EXPR, + TREE_TYPE (sizes), + temv, + sizes); + } + + if (sizes != tem) + { + sizes + = ffecom_3 (COND_EXPR, + TREE_TYPE (sizes), + ffecom_2 (NE_EXPR, + integer_type_node, + t, + null_pointer_node), + sizes, + convert (TREE_TYPE (sizes), + integer_zero_node)); + sizes = ffecom_save_tree (sizes); + + sizes + = tree_cons (NULL_TREE, sizes, tem); + } + + if (sizes) + put_pending_sizes (sizes); + } + +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + DECL_SOMETHING (t) + = ffecom_2 (NE_EXPR, integer_type_node, + t, + null_pointer_node); +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + { + ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } +#endif +#endif +#endif + } + break; + + case FFEINFO_whereCOMMON: + { + ffesymbol cs; + ffeglobal cg; + tree ct; + ffestorag st = ffesymbol_storage (s); + tree type; + int yes; + + cs = ffesymbol_common (s); /* The COMMON area itself. */ + if (st != NULL) /* Else not laid out. */ + { + ffecom_transform_common_ (cs); + st = ffesymbol_storage (s); + } + + yes = suspend_momentary (); + + type = ffecom_type_localvar_ (s, bt, kt); + + cg = ffesymbol_global (cs); /* The global COMMON info. */ + if ((cg == NULL) + || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON)) + ct = NULL_TREE; + else + ct = ffeglobal_hook (cg); /* The common area's tree. */ + + if ((ct == NULL_TREE) + || (st == NULL) + || (type == error_mark_node)) + t = error_mark_node; + else + { + ffetargetOffset offset; + ffestorag cst; + + cst = ffestorag_parent (st); + assert (cst == ffesymbol_storage (cs)); + + offset = ffestorag_modulo (cst) + + ffestorag_offset (st) + - ffestorag_offset (cst); + + ffecom_debug_kludge_ (ct, "COMMON", s, type, offset); + + /* (t_type *) (((char *) &ct) + offset) */ + + t = convert (string_type_node, /* (char *) */ + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ct)), + ct)); + t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), + t, + build_int_2 (offset, 0)); + t = convert (build_pointer_type (type), + t); + + addr = TRUE; + } + + resume_momentary (yes); + } + break; + + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("ENTITY where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindFUNCTION: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_fun_type[bt][kt]; + else + t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + t); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereDUMMY: + assert (ffecom_transform_only_dummies_); + + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_ptr_to_fun_type[bt][kt]; + else + t = build_pointer_type + (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE)); + + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + t); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; + + case FFEINFO_whereCONSTANT: /* Statement function. */ + assert (!ffecom_transform_only_dummies_); + t = ffecom_gen_sfuncdef_ (s, bt, kt); + break; + + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ + + default: + assert ("FUNCTION where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindSUBROUTINE: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereDUMMY: + assert (ffecom_transform_only_dummies_); + + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_ptr_to_subr_type); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; + + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ + + default: + assert ("SUBROUTINE where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindPROGRAM: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("PROGRAM where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindBLOCKDATA: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_blockdata_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("BLOCKDATA where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindCOMMON: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + ffecom_transform_common_ (s); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("COMMON where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindCONSTRUCT: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("CONSTRUCT where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindNAMELIST: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + t = ffecom_transform_namelist_ (s); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("NAMELIST where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + default: + assert ("kind unheard of" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + t = error_mark_node; + break; + } + + ffesymbol_hook (s).decl_tree = t; + ffesymbol_hook (s).length_tree = tlen; + ffesymbol_hook (s).addr = addr; + + lineno = old_lineno; + input_filename = old_input_filename; + + return s; +} + +#endif +/* Transform into ASSIGNable symbol. + + Symbol has already been transformed, but for whatever reason, the + resulting decl_tree has been deemed not usable for an ASSIGN target. + (E.g. it isn't wide enough to hold a pointer.) So, here we invent + another local symbol of type void * and stuff that in the assign_tree + argument. The F77/F90 standards allow this implementation. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_sym_transform_assign_ (ffesymbol s) +{ + tree t; /* Transformed thingy. */ + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + if (ffesymbol_sfdummyparent (s) == NULL) + { + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); + + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } + + assert (!ffecom_transform_only_dummies_); + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_ASSIGN_%s", + ffesymbol_text (s), + 0), + TREE_TYPE (null_pointer_node)); + + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + /* Unlike for regular vars, SAVE status is easy to determine for + ASSIGNed vars, since there's no initialization, there's no + effective storage association (so "SAVE J" does not apply to + K even given "EQUIVALENCE (J,K)"), there's no size issue + to worry about, etc. */ + if ((ffesymbol_is_save (s) || ffe_is_saveall ()) + && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)) + TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */ + else + TREE_STATIC (t) = 0; /* No need to make static. */ + break; + + case FFEINFO_whereCOMMON: + TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */ + break; + + case FFEINFO_whereDUMMY: + /* Note that twinning a DUMMY means the caller won't see + the ASSIGNed value. But both F77 and F90 allow implementations + to do this, i.e. disallow Fortran code that would try and + take advantage of actually putting a label into a variable + via a dummy argument (or any other storage association, for + that matter). */ + TREE_STATIC (t) = 0; + break; + + default: + TREE_STATIC (t) = 0; + break; + } + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + resume_momentary (yes); + + ffesymbol_hook (s).assign_tree = t; + + lineno = old_lineno; + input_filename = old_input_filename; + + return s; +} + +#endif +/* Implement COMMON area in back end. + + Because COMMON-based variables can be referenced in the dimension + expressions of dummy (adjustable) arrays, and because dummies + (in the gcc back end) need to be put in the outer binding level + of a function (which has two binding levels, the outer holding + the dummies and the inner holding the other vars), special care + must be taken to handle COMMON areas. + + The current strategy is basically to always tell the back end about + the COMMON area as a top-level external reference to just a block + of storage of the master type of that area (e.g. integer, real, + character, whatever -- not a structure). As a distinct action, + if initial values are provided, tell the back end about the area + as a top-level non-external (initialized) area and remember not to + allow further initialization or expansion of the area. Meanwhile, + if no initialization happens at all, tell the back end about + the largest size we've seen declared so the space does get reserved. + (This function doesn't handle all that stuff, but it does some + of the important things.) + + Meanwhile, for COMMON variables themselves, just keep creating + references like *((float *) (&common_area + offset)) each time + we reference the variable. In other words, don't make a VAR_DECL + or any kind of component reference (like we used to do before 0.4), + though we might do that as well just for debugging purposes (and + stuff the rtl with the appropriate offset expression). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_transform_common_ (ffesymbol s) +{ + ffestorag st = ffesymbol_storage (s); + ffeglobal g = ffesymbol_global (s); + tree cbt; + tree cbtype; + tree init; + bool is_init = ffestorag_is_init (st); + + assert (st != NULL); + + if ((g == NULL) + || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON)) + return; + + /* First update the size of the area in global terms. */ + + ffeglobal_size_common (s, ffestorag_size (st)); + + if (!ffeglobal_common_init (g)) + is_init = FALSE; /* No explicit init, don't let erroneous joins init. */ + + cbt = ffeglobal_hook (g); + + /* If we already have declared this common block for a previous program + unit, and either we already initialized it or we don't have new + initialization for it, just return what we have without changing it. */ + + if ((cbt != NULL_TREE) + && (!is_init + || !DECL_EXTERNAL (cbt))) + return; + + /* Process inits. */ + + if (is_init) + { + if (ffestorag_init (st) != NULL) + { + init = ffecom_expr (ffestorag_init (st)); + if (init == error_mark_node) + { /* Hopefully the back end complained! */ + init = NULL_TREE; + if (cbt != NULL_TREE) + return; + } + } + else + init = error_mark_node; + } + else + init = NULL_TREE; + + push_obstacks_nochange (); + end_temporary_allocation (); + + /* cbtype must be permanently allocated! */ + + if (init) + cbtype = build_array_type (char_type_node, + build_range_type (integer_type_node, + integer_one_node, + build_int_2 + (ffeglobal_common_size (g), + 0))); + else + cbtype = build_array_type (char_type_node, NULL_TREE); + + if (cbt == NULL_TREE) + { + cbt + = build_decl (VAR_DECL, + ffecom_get_external_identifier_ (s), + cbtype); + TREE_STATIC (cbt) = 1; + TREE_PUBLIC (cbt) = 1; + } + else + { + assert (is_init); + TREE_TYPE (cbt) = cbtype; + } + DECL_EXTERNAL (cbt) = init ? 0 : 1; + DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE; + + cbt = start_decl (cbt, TRUE); + if (ffeglobal_hook (g) != NULL) + assert (cbt == ffeglobal_hook (g)); + + assert (!init || !DECL_EXTERNAL (cbt)); + + /* Make sure that any type can live in COMMON and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the COMMON, but + this seems easy enough. */ + + DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT; + + if (is_init && (ffestorag_init (st) == NULL)) + init = ffecom_init_zero_ (cbt); + + finish_decl (cbt, init, TRUE); + + if (is_init) + ffestorag_set_init (st, ffebld_new_any ()); + + if (init) + { + tree size_tree; + + assert (DECL_SIZE (cbt) != NULL_TREE); + assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST); + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (cbt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffeglobal_common_size (g)); + } + + ffeglobal_set_hook (g, cbt); + + ffestorag_set_hook (st, cbt); + + resume_temporary_allocation (); + pop_obstacks (); +} + +#endif +/* Make master area for local EQUIVALENCE. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_transform_equiv_ (ffestorag eqst) +{ + tree eqt; + tree eqtype; + tree init; + tree high; + bool is_init = ffestorag_is_init (eqst); + int yes; + + assert (eqst != NULL); + + eqt = ffestorag_hook (eqst); + + if (eqt != NULL_TREE) + return; + + /* Process inits. */ + + if (is_init) + { + if (ffestorag_init (eqst) != NULL) + { + init = ffecom_expr (ffestorag_init (eqst)); + if (init == error_mark_node) + init = NULL_TREE; /* Hopefully the back end complained! */ + } + else + init = error_mark_node; + } + else if (ffe_is_init_local_zero ()) + init = error_mark_node; + else + init = NULL_TREE; + + ffecom_member_namelisted_ = FALSE; + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase1_, + eqst); + + yes = suspend_momentary (); + + high = build_int_2 (ffestorag_size (eqst), 0); + TREE_TYPE (high) = ffecom_integer_type_node; + + eqtype = build_array_type (char_type_node, + build_range_type (ffecom_integer_type_node, + ffecom_integer_one_node, + high)); + + eqt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_equiv_%s", + ffesymbol_text + (ffestorag_symbol + (eqst)), + 0), + eqtype); + DECL_EXTERNAL (eqt) = 0; + if (is_init + || ffecom_member_namelisted_ +#ifdef FFECOM_sizeMAXSTACKITEM + || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + && (ffestorag_is_save (eqst) || ffe_is_saveall ()))) + TREE_STATIC (eqt) = 1; + else + TREE_STATIC (eqt) = 0; + TREE_PUBLIC (eqt) = 0; + DECL_CONTEXT (eqt) = current_function_decl; + if (init) + DECL_INITIAL (eqt) = error_mark_node; + else + DECL_INITIAL (eqt) = NULL_TREE; + + eqt = start_decl (eqt, FALSE); + + /* Make sure this shows up as a debug symbol, which is not normally + the case for invented identifiers. */ + + DECL_IGNORED_P (eqt) = 0; + + /* Make sure that any type can live in EQUIVALENCE and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the EQUIVALENCE, but + this seems easy enough. */ + + DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT; + + if ((!is_init && ffe_is_init_local_zero ()) + || (is_init && (ffestorag_init (eqst) == NULL))) + init = ffecom_init_zero_ (eqt); + + finish_decl (eqt, init, FALSE); + + if (is_init) + ffestorag_set_init (eqst, ffebld_new_any ()); + + { + tree size_tree; + + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (eqt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (eqst)); + } + + ffestorag_set_hook (eqst, eqt); + +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase2_, + eqst); +#endif + + resume_momentary (yes); +} + +#endif +/* Implement NAMELIST in back end. See f2c/format.c for more info. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_transform_namelist_ (ffesymbol s) +{ + tree nmlt; + tree nmltype = ffecom_type_namelist_ (); + tree nmlinits; + tree nameinit; + tree varsinit; + tree nvarsinit; + tree field; + tree high; + int yes; + int i; + static int mynumber = 0; + + yes = suspend_momentary (); + + nmlt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_namelist_%d", + NULL, mynumber++), + nmltype); + TREE_STATIC (nmlt) = 1; + DECL_INITIAL (nmlt) = error_mark_node; + + nmlt = start_decl (nmlt, FALSE); + + /* Process inits. */ + + i = strlen (ffesymbol_text (s)); + + high = build_int_2 (i, 0); + TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + + nameinit = ffecom_build_f2c_string_ (i + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + high)), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)), + nameinit); + + varsinit = ffecom_vardesc_array_ (s); + varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)), + varsinit); + TREE_CONSTANT (varsinit) = 1; + TREE_STATIC (varsinit) = 1; + + { + ffebld b; + + for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b)) + ++i; + } + nvarsinit = build_int_2 (i, 0); + TREE_TYPE (nvarsinit) = integer_type_node; + TREE_CONSTANT (nvarsinit) = 1; + TREE_STATIC (nvarsinit) = 1; + + nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit); + TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)), + varsinit); + TREE_CHAIN (TREE_CHAIN (nmlinits)) + = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit); + + nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits); + TREE_CONSTANT (nmlinits) = 1; + TREE_STATIC (nmlinits) = 1; + + finish_decl (nmlt, nmlinits, FALSE); + + nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); + + resume_momentary (yes); + + return nmlt; +} + +#endif + +/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is + analyzed on the assumption it is calculating a pointer to be + indirected through. It must return the proper decl and offset, + taking into account different units of measurements for offsets. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, + tree t) +{ + switch (TREE_CODE (t)) + { + case NOP_EXPR: + case CONVERT_EXPR: + case NON_LVALUE_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); + break; + + case PLUS_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + break; + + if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST) + { + /* An offset into COMMON. */ + *offset = size_binop (PLUS_EXPR, + *offset, + TREE_OPERAND (t, 1)); + /* Convert offset (presumably in bytes) into canonical units + (presumably bits). */ + *offset = size_binop (MULT_EXPR, + *offset, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (t)))); + break; + } + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; + break; + + case PARM_DECL: + *decl = t; + *offset = size_zero_node; + break; + + case ADDR_EXPR: + if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL) + { + /* A reference to COMMON. */ + *decl = TREE_OPERAND (t, 0); + *offset = size_zero_node; + break; + } + /* Fall through. */ + default: + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; + break; + } +} +#endif + +/* Given a tree that is possibly intended for use as an lvalue, return + information representing a canonical view of that tree as a decl, an + offset into that decl, and a size for the lvalue. + + If there's no applicable decl, NULL_TREE is returned for the decl, + and the other fields are left undefined. + + If the tree doesn't fit the recognizable forms, an ERROR_MARK node + is returned for the decl, and the other fields are left undefined. + + Otherwise, the decl returned currently is either a VAR_DECL or a + PARM_DECL. + + The offset returned is always valid, but of course not necessarily + a constant, and not necessarily converted into the appropriate + type, leaving that up to the caller (so as to avoid that overhead + if the decls being looked at are different anyway). + + If the size cannot be determined (e.g. an adjustable array), + an ERROR_MARK node is returned for the size. Otherwise, the + size returned is valid, not necessarily a constant, and not + necessarily converted into the appropriate type as with the + offset. + + Note that the offset and size expressions are expressed in the + base storage units (usually bits) rather than in the units of + the type of the decl, because two decls with different types + might overlap but with apparently non-overlapping array offsets, + whereas converting the array offsets to consistant offsets will + reveal the overlap. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_tree_canonize_ref_ (tree *decl, tree *offset, + tree *size, tree t) +{ + /* The default path is to report a nonexistant decl. */ + *decl = NULL_TREE; + + if (t == NULL_TREE) + return; + + switch (TREE_CODE (t)) + { + case ERROR_MARK: + case IDENTIFIER_NODE: + case INTEGER_CST: + case REAL_CST: + case COMPLEX_CST: + case STRING_CST: + case CONST_DECL: + case PLUS_EXPR: + case MINUS_EXPR: + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case ROUND_DIV_EXPR: + case TRUNC_MOD_EXPR: + case CEIL_MOD_EXPR: + case FLOOR_MOD_EXPR: + case ROUND_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case FIX_TRUNC_EXPR: + case FIX_CEIL_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FLOAT_EXPR: + case EXPON_EXPR: + case NEGATE_EXPR: + case MIN_EXPR: + case MAX_EXPR: + case ABS_EXPR: + case FFS_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_ANDTC_EXPR: + case BIT_NOT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + case LABEL_EXPR: + case COMPONENT_REF: + case COMPOUND_EXPR: + case ADDR_EXPR: + return; + + case VAR_DECL: + case PARM_DECL: + *decl = t; + *offset = size_zero_node; + *size = TYPE_SIZE (TREE_TYPE (t)); + return; + + case ARRAY_REF: + { + tree array = TREE_OPERAND (t, 0); + tree element = TREE_OPERAND (t, 1); + tree init_offset; + + if ((array == NULL_TREE) + || (element == NULL_TREE)) + { + *decl = error_mark_node; + return; + } + + ffecom_tree_canonize_ref_ (decl, &init_offset, size, + array); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + return; + + *offset = size_binop (MULT_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))), + size_binop (MINUS_EXPR, + element, + TYPE_MIN_VALUE + (TYPE_DOMAIN + (TREE_TYPE (array))))); + + *offset = size_binop (PLUS_EXPR, + init_offset, + *offset); + + *size = TYPE_SIZE (TREE_TYPE (t)); + return; + } + + case INDIRECT_REF: + + /* Most of this code is to handle references to COMMON. And so + far that is useful only for calling library functions, since + external (user) functions might reference common areas. But + even calling an external function, it's worthwhile to decode + COMMON references because if not storing into COMMON, we don't + want COMMON-based arguments to gratuitously force use of a + temporary. */ + + *size = TYPE_SIZE (TREE_TYPE (t)); + + ffecom_tree_canonize_ptr_ (decl, offset, + TREE_OPERAND (t, 0)); + + return; + + case CONVERT_EXPR: + case NOP_EXPR: + case MODIFY_EXPR: + case NON_LVALUE_EXPR: + case RESULT_DECL: + case FIELD_DECL: + case COND_EXPR: /* More cases than we can handle. */ + case SAVE_EXPR: + case REFERENCE_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case CALL_EXPR: + default: + *decl = error_mark_node; + return; + } +} +#endif + +/* Do divide operation appropriate to type of operands. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_tree_divide_ (tree tree_type, tree left, tree right, + tree dest_tree, ffebld dest, bool *dest_used) +{ + if ((left == error_mark_node) + || (right == error_mark_node)) + return error_mark_node; + + switch (TREE_CODE (tree_type)) + { + case INTEGER_TYPE: + return ffecom_2 (TRUNC_DIV_EXPR, tree_type, + left, + right); + + case COMPLEX_TYPE: + { + ffecomGfrt ix; + + if (TREE_TYPE (tree_type) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; + + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + break; + + case RECORD_TYPE: + { + ffecomGfrt ix; + + if (TREE_TYPE (TYPE_FIELDS (tree_type)) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; + + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + break; + + default: + return ffecom_2 (RDIV_EXPR, tree_type, + left, + right); + } +} + +#endif +/* ffecom_type_localvar_ -- Build type info for non-dummy variable + + tree type; + ffesymbol s; // the variable's symbol + ffeinfoBasictype bt; // it's basictype + ffeinfoKindtype kt; // it's kindtype + + type = ffecom_type_localvar_(s,bt,kt); + + Handles static arrays, CHARACTER type, etc. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, + ffeinfoKindtype kt) +{ + tree type; + ffebld dl; + ffebld dim; + tree lowt; + tree hight; + + type = ffecom_tree_type[bt][kt]; + if (bt == FFEINFO_basictypeCHARACTER) + { + hight = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node; + + type + = build_array_type + (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } + + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; + + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + + if (ffebld_left (dim) == NULL) + lowt = integer_one_node; + else + lowt = ffecom_expr (ffebld_left (dim)); + + if (TREE_CODE (lowt) != INTEGER_CST) + lowt = variable_size (lowt); + + assert (ffebld_right (dim) != NULL); + hight = ffecom_expr (ffebld_right (dim)); + + if (TREE_CODE (hight) != INTEGER_CST) + hight = variable_size (hight); + + type = build_array_type (type, + build_range_type (ffecom_integer_type_node, + lowt, hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } + + return type; +} + +#endif +/* Build Namelist type. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_namelist_ () +{ + static tree type = NULL_TREE; + + if (type == NULL_TREE) + { + static tree namefield, varsfield, nvarsfield; + tree vardesctype; + + vardesctype = ffecom_type_vardesc_ (); + + push_obstacks_nochange (); + end_temporary_allocation (); + + type = make_node (RECORD_TYPE); + + vardesctype = build_pointer_type (build_pointer_type (vardesctype)); + + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype); + nvarsfield = ffecom_decl_field (type, varsfield, "nvars", + integer_type_node); + + TYPE_FIELDS (type) = namefield; + layout_type (type); + + resume_temporary_allocation (); + pop_obstacks (); + } + + return type; +} + +#endif + +/* Make a copy of a type, assuming caller has switched to the permanent + obstacks and that the type is for an aggregate (array) initializer. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */ +static tree +ffecom_type_permanent_copy_ (tree t) +{ + tree domain; + tree max; + + assert (TREE_TYPE (t) != NULL_TREE); + + domain = TYPE_DOMAIN (t); + + assert (TREE_CODE (t) == ARRAY_TYPE); + assert (TREE_PERMANENT (TREE_TYPE (t))); + assert (TREE_PERMANENT (TREE_TYPE (domain))); + assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain))); + + max = TYPE_MAX_VALUE (domain); + if (!TREE_PERMANENT (max)) + { + assert (TREE_CODE (max) == INTEGER_CST); + + max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max)); + TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain)); + } + + return build_array_type (TREE_TYPE (t), + build_range_type (TREE_TYPE (domain), + TYPE_MIN_VALUE (domain), + max)); +} +#endif + +/* Build Vardesc type. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_vardesc_ () +{ + static tree type = NULL_TREE; + static tree namefield, addrfield, dimsfield, typefield; + + if (type == NULL_TREE) + { + push_obstacks_nochange (); + end_temporary_allocation (); + + type = make_node (RECORD_TYPE); + + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + addrfield = ffecom_decl_field (type, namefield, "addr", + string_type_node); + dimsfield = ffecom_decl_field (type, addrfield, "dims", + ffecom_f2c_ftnlen_type_node); + typefield = ffecom_decl_field (type, dimsfield, "type", + integer_type_node); + + TYPE_FIELDS (type) = namefield; + layout_type (type); + + resume_temporary_allocation (); + pop_obstacks (); + } + + return type; +} + +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_ (ffebld expr) +{ + ffesymbol s; + + assert (ffebld_op (expr) == FFEBLD_opSYMTER); + s = ffebld_symter (expr); + + if (ffesymbol_hook (s).vardesc_tree == NULL_TREE) + { + int i; + tree vardesctype = ffecom_type_vardesc_ (); + tree var; + tree nameinit; + tree dimsinit; + tree addrinit; + tree typeinit; + tree field; + tree varinits; + int yes; + static int mynumber = 0; + + yes = suspend_momentary (); + + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_vardesc_%d", + NULL, mynumber++), + vardesctype); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + + var = start_decl (var, FALSE); + + /* Process inits. */ + + nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) + + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (nameinit)), + nameinit); + + addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit); + + dimsinit = ffecom_vardesc_dims_ (s); + + if (typeinit == NULL_TREE) + { + ffeinfoBasictype bt = ffesymbol_basictype (s); + ffeinfoKindtype kt = ffesymbol_kindtype (s); + int tc = ffecom_f2c_typecode (bt, kt); + + assert (tc != -1); + typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0); + } + else + typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit); + + varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)), + nameinit); + TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)), + addrinit); + TREE_CHAIN (TREE_CHAIN (varinits)) + = build_tree_list ((field = TREE_CHAIN (field)), dimsinit); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits))) + = build_tree_list ((field = TREE_CHAIN (field)), typeinit); + + varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits); + TREE_CONSTANT (varinits) = 1; + TREE_STATIC (varinits) = 1; + + finish_decl (var, varinits, FALSE); + + var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); + + resume_momentary (yes); + + ffesymbol_hook (s).vardesc_tree = var; + } + + return ffesymbol_hook (s).vardesc_tree; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_array_ (ffesymbol s) +{ + ffebld b; + tree list; + tree item = NULL_TREE; + tree var; + int i; + int yes; + static int mynumber = 0; + + for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s); + b != NULL; + b = ffebld_trail (b), ++i) + { + tree t; + + t = ffecom_vardesc_ (ffebld_head (b)); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + + yes = suspend_momentary (); + + item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()), + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + + var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); + + resume_momentary (yes); + + return var; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_dims_ (ffesymbol s) +{ + if (ffesymbol_dims (s) == NULL) + return convert (ffecom_f2c_ptr_to_ftnlen_type_node, + integer_zero_node); + + { + ffebld b; + ffebld e; + tree list; + tree backlist; + tree item = NULL_TREE; + tree var; + int yes; + tree numdim; + tree numelem; + tree baseoff = NULL_TREE; + static int mynumber = 0; + + numdim = build_int_2 ((int) ffesymbol_rank (s), 0); + TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node; + + numelem = ffecom_expr (ffesymbol_arraysize (s)); + TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node; + + list = NULL_TREE; + backlist = NULL_TREE; + for (b = ffesymbol_dims (s), e = ffesymbol_extents (s); + b != NULL; + b = ffebld_trail (b), e = ffebld_trail (e)) + { + tree t; + tree low; + tree back; + + if (ffebld_trail (b) == NULL) + t = NULL_TREE; + else + { + t = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (ffebld_head (e))); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + + if (ffebld_left (ffebld_head (b)) == NULL) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (ffebld_head (b))); + low = convert (ffecom_f2c_ftnlen_type_node, low); + + back = build_tree_list (low, t); + TREE_CHAIN (back) = backlist; + backlist = back; + } + + for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item)) + { + if (TREE_VALUE (item) == NULL_TREE) + baseoff = TREE_PURPOSE (item); + else + baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + TREE_PURPOSE (item), + ffecom_2 (MULT_EXPR, + ffecom_f2c_ftnlen_type_node, + TREE_VALUE (item), + baseoff)); + } + + /* backlist now dead, along with all TREE_PURPOSEs on it. */ + + baseoff = build_tree_list (NULL_TREE, baseoff); + TREE_CHAIN (baseoff) = list; + + numelem = build_tree_list (NULL_TREE, numelem); + TREE_CHAIN (numelem) = baseoff; + + numdim = build_tree_list (NULL_TREE, numdim); + TREE_CHAIN (numdim) = numelem; + + yes = suspend_momentary (); + + item = build_array_type (ffecom_f2c_ftnlen_type_node, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 + ((int) ffesymbol_rank (s) + + 2, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, numdim); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + + var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); + + var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var); + + resume_momentary (yes); + + return var; + } +} + +#endif +/* Essentially does a "fold (build1 (code, type, node))" while checking + for certain housekeeping things. + + NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use + ffecom_1_fn instead. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_1 (enum tree_code code, tree type, tree node) +{ + tree item; + + if ((node == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + if (code == ADDR_EXPR) + { + if (!mark_addressable (node)) + assert ("can't mark_addressable this node!" == NULL); + } + + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + { + tree realtype; + + case REALPART_EXPR: + item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node))); + break; + + case IMAGPART_EXPR: + item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node)))); + break; + + + case NEGATE_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build1 (code, type, node); + break; + } + node = ffecom_stabilize_aggregate_ (node); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node)), + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node))); + break; + + default: + item = build1 (code, type, node); + break; + } + + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if ((code == ADDR_EXPR) && staticp (node)) + TREE_CONSTANT (item) = 1; + return fold (item); +} +#endif + +/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except + handles TREE_CODE (node) == FUNCTION_DECL. In particular, + does not set TREE_ADDRESSABLE (because calling an inline + function does not mean the function needs to be separately + compiled). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_1_fn (tree node) +{ + tree item; + tree type; + + if (node == error_mark_node) + return error_mark_node; + + type = build_type_variant (TREE_TYPE (node), + TREE_READONLY (node), + TREE_THIS_VOLATILE (node)); + item = build1 (ADDR_EXPR, + build_pointer_type (type), node); + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if (staticp (node)) + TREE_CONSTANT (item) = 1; + return fold (item); +} +#endif + +/* Essentially does a "fold (build (code, type, node1, node2))" while + checking for certain housekeeping things. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_2 (enum tree_code code, tree type, tree node1, + tree node2) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + { + tree a, b, c, d, realtype; + + case CONJ_EXPR: + assert ("no CONJ_EXPR support yet" == NULL); + return error_mark_node; + + case COMPLEX_EXPR: + item = build_tree_list (TYPE_FIELDS (type), node1); + TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2); + item = build (CONSTRUCTOR, type, NULL_TREE, item); + break; + + case PLUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case MINUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case MULT_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + a = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node1)); + b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node1)); + c = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node2)); + d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node2)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + c), + ffecom_2 (MULT_EXPR, realtype, + b, + d)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + d), + ffecom_2 (MULT_EXPR, realtype, + c, + b))); + break; + + case EQ_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ANDIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case NE_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ORIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + default: + item = build (code, type, node1, node2); + break; + } + + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)) + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint + + ffesymbol s; // the ENTRY point itself + if (ffecom_2pass_advise_entrypoint(s)) + // the ENTRY point has been accepted + + Does whatever compiler needs to do when it learns about the entrypoint, + like determine the return type of the master function, count the + number of entrypoints, etc. Returns FALSE if the return type is + not compatible with the return type(s) of other entrypoint(s). + + NOTE: for every call to this fn that returns TRUE, _do_entrypoint must + later (after _finish_progunit) be called with the same entrypoint(s) + as passed to this fn for which TRUE was returned. + + 03-Jan-92 JCB 2.0 + Return FALSE if the return type conflicts with previous entrypoints. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +bool +ffecom_2pass_advise_entrypoint (ffesymbol entry) +{ + ffebld list; /* opITEM. */ + ffebld mlist; /* opITEM. */ + ffebld plist; /* opITEM. */ + ffebld arg; /* ffebld_head(opITEM). */ + ffebld item; /* opITEM. */ + ffesymbol s; /* ffebld_symter(arg). */ + ffeinfoBasictype bt = ffesymbol_basictype (entry); + ffeinfoKindtype kt = ffesymbol_kindtype (entry); + ffetargetCharacterSize size = ffesymbol_size (entry); + bool ok; + + if (ffecom_num_entrypoints_ == 0) + { /* First entrypoint, make list of main + arglist's dummies. */ + assert (ffecom_primary_entry_ != NULL); + + ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_); + ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_); + ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_); + + for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); + plist = item; + } + } + + /* If necessary, scan entry arglist for alternate returns. Do this scan + apparently redundantly (it's done below to UNIONize the arglists) so + that we don't complain about RETURN 1 if an offending ENTRY is the only + one with an alternate return. */ + + if (!ffecom_is_altreturning_) + { + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } + + /* Now check type compatibility. */ + + switch (ffecom_master_bt_) + { + case FFEINFO_basictypeNONE: + ok = (bt != FFEINFO_basictypeCHARACTER); + break; + + case FFEINFO_basictypeCHARACTER: + ok + = (bt == FFEINFO_basictypeCHARACTER) + && (kt == ffecom_master_kt_) + && (size == ffecom_master_size_); + break; + + case FFEINFO_basictypeANY: + return FALSE; /* Just don't bother. */ + + default: + if (bt == FFEINFO_basictypeCHARACTER) + { + ok = FALSE; + break; + } + ok = TRUE; + if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_)) + { + ffecom_master_bt_ = FFEINFO_basictypeNONE; + ffecom_master_kt_ = FFEINFO_kindtypeNONE; + } + break; + } + + if (!ok) + { + ffebad_start (FFEBAD_ENTRY_CONFLICTS); + ffest_ffebad_here_current_stmt (0); + ffebad_finish (); + return FALSE; /* Can't handle entrypoint. */ + } + + /* Entrypoint type compatible with previous types. */ + + ++ffecom_num_entrypoints_; + + /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */ + + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + s = ffebld_symter (arg); + for (plist = NULL, mlist = ffecom_master_arglist_; + mlist != NULL; + plist = mlist, mlist = ffebld_trail (mlist)) + { /* plist points to previous item for easy + appending of arg. */ + if (ffebld_symter (ffebld_head (mlist)) == s) + break; /* Already have this arg in the master list. */ + } + if (mlist != NULL) + continue; /* Already have this arg in the master list. */ + + /* Append this arg to the master list. */ + + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); + } + + return TRUE; +} + +#endif +/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint + + ffesymbol s; // the ENTRY point itself + ffecom_2pass_do_entrypoint(s); + + Does whatever compiler needs to do to make the entrypoint actually + happen. Must be called for each entrypoint after + ffecom_finish_progunit is called. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_2pass_do_entrypoint (ffesymbol entry) +{ + static int mfn_num = 0; + static int ent_num; + + if (mfn_num != ffecom_num_fns_) + { /* First entrypoint for this program unit. */ + ent_num = 1; + mfn_num = ffecom_num_fns_; + ffecom_do_entry_ (ffecom_primary_entry_, 0); + } + else + ++ent_num; + + --ffecom_num_entrypoints_; + + ffecom_do_entry_ (entry, ent_num); +} + +#endif + +/* Essentially does a "fold (build (code, type, node1, node2))" while + checking for certain housekeeping things. Always sets + TREE_SIDE_EFFECTS. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_2s (enum tree_code code, tree type, tree node1, + tree node2) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2); + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* Essentially does a "fold (build (code, type, node1, node2, node3))" while + checking for certain housekeeping things. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_3 (enum tree_code code, tree type, tree node1, + tree node2, tree node3) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2, node3); + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2) + || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3))) + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* Essentially does a "fold (build (code, type, node1, node2, node3))" while + checking for certain housekeeping things. Always sets + TREE_SIDE_EFFECTS. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_3s (enum tree_code code, tree type, tree node1, + tree node2, tree node3) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2, node3); + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* ffecom_arg_expr -- Transform argument expr into gcc tree + + See use by ffecom_list_expr. + + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, but does NOT set the length return value to a tree + that specifies the length of the result. (In other words, the length + variable is always set to NULL_TREE, because a length is never passed.) + + 21-Dec-91 JCB 1.1 + Don't set returned length, since nobody needs it (yet; someday if + we allow CHARACTER*(*) dummies to statement functions, we'll need + it). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_arg_expr (ffebld expr, tree *length) +{ + tree ign; + + *length = NULL_TREE; + + if (expr == NULL) + return integer_zero_node; + + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (expr); + + return ffecom_arg_ptr_to_expr (expr, &ign); +} + +#endif +/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree + + See use by ffecom_list_ptr_to_expr. + + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_ptr_to_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, AND sets the length return value to a tree that + specifies the length of the result. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_arg_ptr_to_expr (ffebld expr, tree *length) +{ + tree item; + tree ign_length; + ffecomConcatList_ catlist; + + *length = NULL_TREE; + + if (expr == NULL) + return integer_zero_node; + + switch (ffebld_op (expr)) + { + case FFEBLD_opPERCENT_VAL: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (ffebld_left (expr)); + { + tree temp_exp; + tree temp_length; + + temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length); + return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)), + temp_exp); + } + + case FFEBLD_opPERCENT_REF: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (ffebld_left (expr)); + ign_length = NULL_TREE; + length = &ign_length; + expr = ffebld_left (expr); + break; + + case FFEBLD_opPERCENT_DESCR: + switch (ffeinfo_basictype (ffebld_info (expr))) + { +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + case FFEINFO_basictypeHOLLERITH: +#endif + case FFEINFO_basictypeCHARACTER: + break; /* Passed by descriptor anyway. */ + + default: + item = ffecom_ptr_to_expr (expr); + if (item != error_mark_node) + *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item))); + break; + } + break; + + default: + break; + } + +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH) + { /* Pass Hollerith by descriptor. */ + ffetargetHollerith h; + + assert (ffebld_op (expr) == FFEBLD_opCONTER); + h = ffebld_cu_val_hollerith (ffebld_constant_union + (ffebld_conter (expr))); + *length + = build_int_2 (h.length, 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } +#endif + + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (expr); + + assert (ffeinfo_kindtype (ffebld_info (expr)) + == FFEINFO_kindtypeCHARACTER1); + + catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + *length = ffecom_f2c_ftnlen_zero_node; + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + ffecom_concat_list_kill_ (catlist); + return null_pointer_node; + + case 1: /* The (fairly) easy case. */ + ffecom_char_args_ (&item, length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; + + default: /* Must actually concatenate things. */ + break; + } + + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; + tree temporary; + tree num; + tree known_length; + ffetargetCharacterSize sz; + + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array + = items + = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + + known_length = ffecom_f2c_ftnlen_zero_node; + + for (i = 0; i < count; ++i) + { + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + *length = error_mark_node; + return error_mark_node; + } + + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + clength = ffecom_save_tree (clength); + known_length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + known_length, + clength); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } + + sz = ffecom_concat_list_maxlen_ (catlist); + assert (sz != FFETARGET_charactersizeNONE); + + temporary = ffecom_push_tempvar (char_type_node, + sz, -1, TRUE); + temporary = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (temporary)), + temporary); + + item = build_tree_list (NULL_TREE, temporary); + TREE_CHAIN (item) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (item)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + num = build_int_2 (sz, 0); + TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node; + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) + = build_tree_list (NULL_TREE, num); + + item = ffecom_call_gfrt (FFECOM_gfrtCAT, item); + TREE_SIDE_EFFECTS (item) = 1; + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), + item, + temporary); + + *length = known_length; + } + + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; +} + +#endif +/* ffecom_call_gfrt -- Generate call to run-time function + + tree expr; + expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE); + + The first arg is the GNU Fortran Run-Time function index, the second + arg is the list of arguments to pass to it. Returned is the expression + (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the + result (which may be void). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_call_gfrt (ffecomGfrt ix, tree args) +{ + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], + NULL_TREE, args, NULL_TREE, NULL, + NULL, NULL_TREE, TRUE); +} +#endif + +/* ffecom_constantunion -- Transform constant-union to tree + + ffebldConstantUnion cu; // the constant to transform + ffeinfoBasictype bt; // its basic type + ffeinfoKindtype kt; // its kind type + tree tree_type; // ffecom_tree_type[bt][kt] + ffecom_constantunion(&cu,bt,kt,tree_type); */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, + ffeinfoKindtype kt, tree tree_type) +{ + tree item; + + switch (bt) + { + case FFEINFO_basictypeINTEGER: + { + int val; + + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + val = ffebld_cu_val_integer1 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + val = ffebld_cu_val_integer2 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + val = ffebld_cu_val_integer3 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + val = ffebld_cu_val_integer4 (*cu); + break; +#endif + + default: + assert ("bad INTEGER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } + break; + + case FFEINFO_basictypeLOGICAL: + { + int val; + + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_logical1 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + val = ffebld_cu_val_logical2 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + val = ffebld_cu_val_logical3 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + val = ffebld_cu_val_logical4 (*cu); + break; +#endif + + default: + assert ("bad LOGICAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } + break; + + case FFEINFO_basictypeREAL: + { + REAL_VALUE_TYPE val; + + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu)); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu)); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu)); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu)); + break; +#endif + + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_real (tree_type, val); + } + break; + + case FFEINFO_basictypeCOMPLEX: + { + REAL_VALUE_TYPE real; + REAL_VALUE_TYPE imag; + tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real); + imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real); + imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real); + imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real); + imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary); + break; +#endif + + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = ffecom_build_complex_constant_ (tree_type, + build_real (el_type, real), + build_real (el_type, imag)); + } + break; + + case FFEINFO_basictypeCHARACTER: + { /* Happens only in DATA and similar contexts. */ + ffetargetCharacter1 val; + + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_character1 (*cu); + break; +#endif + + default: + assert ("bad CHARACTER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_string (ffetarget_length_character1 (val), + ffetarget_text_character1 (val)); + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (ffetarget_length_character1 + (val), 0))), + 1, 0); + } + break; + + case FFEINFO_basictypeHOLLERITH: + { + ffetargetHollerith h; + + h = ffebld_cu_val_hollerith (*cu); + + /* If not at least as wide as default INTEGER, widen it. */ + if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE) + item = build_string (h.length, h.text); + else + { + char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE]; + + memcpy (str, h.text, h.length); + memset (&str[h.length], ' ', + FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE + - h.length); + item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE, + str); + } + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (h.length, 0))), + 1, 0); + } + break; + + case FFEINFO_basictypeTYPELESS: + { + ffetargetInteger1 ival; + ffetargetTypeless tless; + ffebad error; + + tless = ffebld_cu_val_typeless (*cu); + error = ffetarget_convert_integer1_typeless (&ival, tless); + assert (error == FFEBAD); + + item = build_int_2 ((int) ival, 0); + } + break; + + default: + assert ("not yet on constant type" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + + TREE_CONSTANT (item) = 1; + + return item; +} + +#endif + +/* Handy way to make a field in a struct/union. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_decl_field (tree context, tree prevfield, + char *name, tree type) +{ + tree field; + + field = build_decl (FIELD_DECL, get_identifier (name), type); + DECL_CONTEXT (field) = context; + DECL_FRAME_SIZE (field) = 0; + if (prevfield != NULL_TREE) + TREE_CHAIN (prevfield) = field; + + return field; +} + +#endif + +void +ffecom_close_include (FILE *f) +{ +#if FFECOM_GCC_INCLUDE + ffecom_close_include_ (f); +#endif +} + +int +ffecom_decode_include_option (char *spec) +{ +#if FFECOM_GCC_INCLUDE + return ffecom_decode_include_option_ (spec); +#else + return 1; +#endif +} + +/* ffecom_end_transition -- Perform end transition on all symbols + + ffecom_end_transition(); + + Calls ffecom_sym_end_transition for each global and local symbol. */ + +void +ffecom_end_transition () +{ +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffebld item; +#endif + + if (ffe_is_ffedebug ()) + fprintf (dmpout, "; end_stmt_transition\n"); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffecom_list_blockdata_ = NULL; + ffecom_list_common_ = NULL; +#endif + + ffesymbol_drive (ffecom_sym_end_transition); + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffecom_start_progunit_ (); + + for (item = ffecom_list_blockdata_; + item != NULL; + item = ffebld_trail (item)) + { + ffebld callee; + ffesymbol s; + tree dt; + tree t; + tree var; + int yes; + static int number = 0; + + callee = ffebld_head (item); + s = ffebld_symter (callee); + t = ffesymbol_hook (s).decl_tree; + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + } + + yes = suspend_momentary (); + + dt = build_pointer_type (TREE_TYPE (t)); + + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_forceload_%d", + NULL, number++), + dt); + DECL_EXTERNAL (var) = 0; + TREE_STATIC (var) = 1; + TREE_PUBLIC (var) = 0; + DECL_INITIAL (var) = error_mark_node; + TREE_USED (var) = 1; + + var = start_decl (var, FALSE); + + t = ffecom_1 (ADDR_EXPR, dt, t); + + finish_decl (var, t, FALSE); + + resume_momentary (yes); + } + + /* This handles any COMMON areas that weren't referenced but have, for + example, important initial data. */ + + for (item = ffecom_list_common_; + item != NULL; + item = ffebld_trail (item)) + ffecom_transform_common_ (ffebld_symter (ffebld_head (item))); + + ffecom_list_common_ = NULL; +#endif +} + +/* ffecom_exec_transition -- Perform exec transition on all symbols + + ffecom_exec_transition(); + + Calls ffecom_sym_exec_transition for each global and local symbol. + Make sure error updating not inhibited. */ + +void +ffecom_exec_transition () +{ + bool inhibited; + + if (ffe_is_ffedebug ()) + fprintf (dmpout, "; exec_stmt_transition\n"); + + inhibited = ffebad_inhibit (); + ffebad_set_inhibit (FALSE); + + ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */ + ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */ + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } + + if (inhibited) + ffebad_set_inhibit (TRUE); +} + +/* ffecom_expand_let_stmt -- Compile let (assignment) statement + + ffebld dest; + ffebld source; + ffecom_expand_let_stmt(dest,source); + + Convert dest and source using ffecom_expr, then join them + with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_expand_let_stmt (ffebld dest, ffebld source) +{ + tree dest_tree; + tree dest_length; + tree source_tree; + tree expr_tree; + + if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER) + { + bool dest_used; + + dest_tree = ffecom_expr_rw (dest); + if (dest_tree == error_mark_node) + return; + + if ((TREE_CODE (dest_tree) != VAR_DECL) + || TREE_ADDRESSABLE (dest_tree)) + source_tree = ffecom_expr_ (source, dest_tree, dest, + &dest_used, FALSE); + else + { + source_tree = ffecom_expr (source); + dest_used = FALSE; + } + if (source_tree == error_mark_node) + return; + + if (dest_used) + expr_tree = source_tree; + else + expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, + dest_tree, + source_tree); + + expand_expr_stmt (expr_tree); + return; + } + + ffecom_push_calltemps (); + ffecom_char_args_ (&dest_tree, &dest_length, dest); + ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), + source); + ffecom_pop_calltemps (); +} + +#endif +/* ffecom_expr -- Transform expr into gcc tree + + tree t; + ffebld expr; // FFE expression. + tree = ffecom_expr(expr); + + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr (ffebld expr) +{ + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, + FALSE); +} + +#endif +/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_assign (ffebld expr) +{ + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, + TRUE); +} + +#endif +/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_assign_w (ffebld expr) +{ + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, + TRUE); +} + +#endif +/* Transform expr for use as into read/write tree and stabilize the + reference. Not for use on CHARACTER expressions. + + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_rw (ffebld expr) +{ + assert (expr != NULL); + + return stabilize_reference (ffecom_expr (expr)); +} + +#endif +/* Do global stuff. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_compile () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + + ffeglobal_drive (ffecom_finish_global_); +} + +#endif +/* Public entry point for front end to access finish_decl. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_decl (tree decl, tree init, bool is_top_level) +{ + assert (!is_top_level); + finish_decl (decl, init, FALSE); +} + +#endif +/* Finish a program unit. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_progunit () +{ + ffecom_end_compstmt_ (); + + ffecom_previous_function_decl_ = current_function_decl; + ffecom_which_entrypoint_decl_ = NULL_TREE; + + finish_function (0); +} + +#endif +/* Wrapper for get_identifier. pattern is like "...%s...", text is + inserted into final name in place of "%s", or if text is NULL, + pattern is like "...%d..." and text form of number is inserted + in place of "%d". */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_get_invented_identifier (char *pattern, char *text, int number) +{ + tree decl; + char *nam; + mallocSize lenlen; + char space[66]; + + if (text == NULL) + lenlen = strlen (pattern) + 20; + else + lenlen = strlen (pattern) + strlen (text) - 1; + if (lenlen > ARRAY_SIZE (space)) + nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen); + else + nam = &space[0]; + if (text == NULL) + sprintf (&nam[0], pattern, number); + else + sprintf (&nam[0], pattern, text); + decl = get_identifier (nam); + if (lenlen > ARRAY_SIZE (space)) + malloc_kill_ks (malloc_pool_image (), nam, lenlen); + + IDENTIFIER_INVENTED (decl) = 1; + + return decl; +} + +ffeinfoBasictype +ffecom_gfrt_basictype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + return FFEINFO_basictypeNONE; + + case FFECOM_rttypeINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeINTEGER_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLONGINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLOGICAL_: + return FFEINFO_basictypeLOGICAL; + + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeDOUBLE_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeCHARACTER_: + return FFEINFO_basictypeCHARACTER; + + default: + return FFEINFO_basictypeANY; + } +} + +ffeinfoKindtype +ffecom_gfrt_kindtype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + return FFEINFO_kindtypeNONE; + + case FFECOM_rttypeINT_: + return FFEINFO_kindtypeINTEGER1; + + case FFECOM_rttypeINTEGER_: + return FFEINFO_kindtypeINTEGER1; + + case FFECOM_rttypeLONGINT_: + return FFEINFO_kindtypeINTEGER4; + + case FFECOM_rttypeLOGICAL_: + return FFEINFO_kindtypeLOGICAL1; + + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_kindtypeREAL1; + + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_kindtypeREAL1; + + case FFECOM_rttypeDOUBLE_: + return FFEINFO_kindtypeREAL2; + + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_kindtypeREAL2; + + case FFECOM_rttypeCHARACTER_: + return FFEINFO_kindtypeCHARACTER1; + + default: + return FFEINFO_kindtypeANY; + } +} + +void +ffecom_init_0 () +{ + tree endlink; + int i; + int j; + tree t; + tree field; + ffetype type; + ffetype base_type; + + /* This block of code comes from the now-obsolete cktyps.c. It checks + whether the compiler environment is buggy in known ways, some of which + would, if not explicitly checked here, result in subtle bugs in g77. */ + + if (ffe_is_do_internal_checks ()) + { + static char names[][12] + = + {"bar", "bletch", "foo", "foobar"}; + char *name; + unsigned long ul; + double fl; + + name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), + (int (*)()) strcmp); + if (name != (char *) &names[2]) + { + assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h" + == NULL); + abort (); + } + + ul = strtoul ("123456789", NULL, 10); + if (ul != 123456789L) + { + assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\ + in proj.h" == NULL); + abort (); + } + + fl = atof ("56.789"); + if ((fl < 56.788) || (fl > 56.79)) + { + assert ("atof not type double, fix your #include <stdio.h>" + == NULL); + abort (); + } + } + +#if FFECOM_GCC_INCLUDE + ffecom_initialize_char_syntax_ (); +#endif + + ffecom_outer_function_decl_ = NULL_TREE; + current_function_decl = NULL_TREE; + named_labels = NULL_TREE; + current_binding_level = NULL_BINDING_LEVEL; + free_binding_level = NULL_BINDING_LEVEL; + pushlevel (0); /* make the binding_level structure for + global names */ + global_binding_level = current_binding_level; + + /* Define `int' and `char' first so that dbx will output them first. */ + + integer_type_node = make_signed_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), + integer_type_node)); + + char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), + char_type_node)); + + long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), + long_integer_type_node)); + + unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), + unsigned_type_node)); + + long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), + long_unsigned_type_node)); + + long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), + long_long_integer_type_node)); + + long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), + long_long_unsigned_type_node)); + + sizetype + = TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))); + + TREE_TYPE (TYPE_SIZE (integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (char_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (unsigned_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_unsigned_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_long_integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node)) = sizetype; + + error_mark_node = make_node (ERROR_MARK); + TREE_TYPE (error_mark_node) = error_mark_node; + + short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), + short_integer_type_node)); + + short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), + short_unsigned_type_node)); + + /* Define both `signed char' and `unsigned char'. */ + signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), + signed_char_type_node)); + + unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), + unsigned_char_type_node)); + + float_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE; + layout_type (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), + float_type_node)); + + double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE; + layout_type (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), + double_type_node)); + + long_double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE; + layout_type (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), + long_double_type_node)); + + complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), + complex_integer_type_node)); + + complex_float_type_node = ffecom_make_complex_type_ (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), + complex_float_type_node)); + + complex_double_type_node = ffecom_make_complex_type_ (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), + complex_double_type_node)); + + complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), + complex_long_double_type_node)); + + integer_zero_node = build_int_2 (0, 0); + TREE_TYPE (integer_zero_node) = integer_type_node; + integer_one_node = build_int_2 (1, 0); + TREE_TYPE (integer_one_node) = integer_type_node; + + size_zero_node = build_int_2 (0, 0); + TREE_TYPE (size_zero_node) = sizetype; + size_one_node = build_int_2 (1, 0); + TREE_TYPE (size_one_node) = sizetype; + + void_type_node = make_node (VOID_TYPE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), + void_type_node)); + layout_type (void_type_node); /* Uses integer_zero_node */ + /* We are not going to have real types in C with less than byte alignment, + so we might as well not have any types that claim to have it. */ + TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; + + null_pointer_node = build_int_2 (0, 0); + TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node); + layout_type (TREE_TYPE (null_pointer_node)); + + string_type_node = build_pointer_type (char_type_node); + + ffecom_tree_fun_type_void + = build_function_type (void_type_node, NULL_TREE); + + ffecom_tree_ptr_to_fun_type_void + = build_pointer_type (ffecom_tree_fun_type_void); + + endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + + float_ftype_float + = build_function_type (float_type_node, + tree_cons (NULL_TREE, float_type_node, endlink)); + + double_ftype_double + = build_function_type (double_type_node, + tree_cons (NULL_TREE, double_type_node, endlink)); + + ldouble_ftype_ldouble + = build_function_type (long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + endlink)); + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + ffecom_tree_type[i][j] = NULL_TREE; + ffecom_tree_fun_type[i][j] = NULL_TREE; + ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE; + ffecom_f2c_typecode_[i][j] = -1; + } + + /* Set up standard g77 types. Note that INTEGER and LOGICAL are set + to size FLOAT_TYPE_SIZE because they have to be the same size as + REAL, which also is FLOAT_TYPE_SIZE, according to the standard. + Compiler options and other such stuff that change the ways these + types are set should not affect this particular setup. */ + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger1)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1] + = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger2)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2] + = t = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("word"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger3)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3] + = t = make_unsigned_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger4)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4] + = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"), + t)); + +#if 0 + if (ffe_is_do_internal_checks () + && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE + && LONG_TYPE_SIZE != CHAR_TYPE_SIZE + && LONG_TYPE_SIZE != SHORT_TYPE_SIZE + && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE) + { + fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n", + LONG_TYPE_SIZE); + } +#endif + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical1)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical2)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical3)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical4)); + + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE; + pushdecl (build_decl (TYPE_DECL, get_identifier ("real"), + t)); + layout_type (t); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal1)); + + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"), + t)); + layout_type (t); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal2)); + + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex1)); + + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, + type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex2)); + + /* Make function and ptr-to-function types for non-CHARACTER types. */ + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if ((t = ffecom_tree_type[i][j]) != NULL_TREE) + { + if (i == FFEINFO_basictypeINTEGER) + { + /* Figure out the smallest INTEGER type that can hold + a pointer on this machine. */ + if (GET_MODE_SIZE (TYPE_MODE (t)) + >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) + { + if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE) + || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_])) + > GET_MODE_SIZE (TYPE_MODE (t)))) + ffecom_pointer_kind_ = j; + } + } + else if (i == FFEINFO_basictypeCOMPLEX) + t = void_type_node; + /* For f2c compatibility, REAL functions are really + implemented as DOUBLE PRECISION. */ + else if ((i == FFEINFO_basictypeREAL) + && (j == FFEINFO_kindtypeREAL1)) + t = ffecom_tree_type + [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]; + + t = ffecom_tree_fun_type[i][j] = build_function_type (t, + NULL_TREE); + ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t); + } + } + + /* Set up pointer types. */ + + if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE) + fatal ("no INTEGER type can hold a pointer on this configuration"); + else if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_); + type = ffetype_new (); + ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT), + 7, type); + + if (ffe_is_ugly_assign ()) + ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */ + else + ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT; + if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_); + + ffecom_integer_type_node + = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]; + ffecom_integer_zero_node = convert (ffecom_integer_type_node, + integer_zero_node); + ffecom_integer_one_node = convert (ffecom_integer_type_node, + integer_one_node); + + /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional. + Turns out that by TYLONG, runtime/libI77/lio.h really means + "whatever size an ftnint is". For consistency and sanity, + com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen + all are INTEGER, which we also make out of whatever back-end + integer type is FLOAT_TYPE_SIZE bits wide. This change, from + LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to + accommodate machines like the Alpha. Note that this suggests + f2c and libf2c are missing a distinction perhaps needed on + some machines between "int" and "long int". -- burley 0.5.5 950215 */ + + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLONG); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE, + FFETARGET_f2cTYSHORT); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE, + FFETARGET_f2cTYINT1); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL2); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL1); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD /* ~~~ */); + + /* CHARACTER stuff is all special-cased, so it is not handled in the above + loop. CHARACTER items are built as arrays of unsigned char. */ + + ffecom_tree_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = t = char_type_node; + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCHARACTER, + FFEINFO_kindtypeCHARACTER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) + == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0])); + + ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void; + ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] + = ffecom_tree_ptr_to_fun_type_void; + ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1] + = FFETARGET_f2cTYCHAR; + + ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY] + = 0; + + /* Make multi-return-value type and fields. */ + + ffecom_multi_type_node_ = make_node (UNION_TYPE); + + field = NULL_TREE; + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + char name[30]; + + if (ffecom_tree_type[i][j] == NULL_TREE) + continue; /* Not supported. */ + sprintf (&name[0], "bt_%s_kt_%s", + ffeinfo_basictype_string ((ffeinfoBasictype) i), + ffeinfo_kindtype_string ((ffeinfoKindtype) j)); + ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL, + get_identifier (name), + ffecom_tree_type[i][j]); + DECL_CONTEXT (ffecom_multi_fields_[i][j]) + = ffecom_multi_type_node_; + DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0; + TREE_CHAIN (ffecom_multi_fields_[i][j]) = field; + field = ffecom_multi_fields_[i][j]; + } + + TYPE_FIELDS (ffecom_multi_type_node_) = field; + layout_type (ffecom_multi_type_node_); + + /* Subroutines usually return integer because they might have alternate + returns. */ + + ffecom_tree_subr_type + = build_function_type (integer_type_node, NULL_TREE); + ffecom_tree_ptr_to_subr_type + = build_pointer_type (ffecom_tree_subr_type); + ffecom_tree_blockdata_type + = build_function_type (void_type_node, NULL_TREE); + + builtin_function ("__builtin_sqrtf", float_ftype_float, + BUILT_IN_FSQRT, "sqrtf"); + builtin_function ("__builtin_fsqrt", double_ftype_double, + BUILT_IN_FSQRT, "sqrt"); + builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, + BUILT_IN_FSQRT, "sqrtl"); + builtin_function ("__builtin_sinf", float_ftype_float, + BUILT_IN_SIN, "sinf"); + builtin_function ("__builtin_sin", double_ftype_double, + BUILT_IN_SIN, "sin"); + builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, + BUILT_IN_SIN, "sinl"); + builtin_function ("__builtin_cosf", float_ftype_float, + BUILT_IN_COS, "cosf"); + builtin_function ("__builtin_cos", double_ftype_double, + BUILT_IN_COS, "cos"); + builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, + BUILT_IN_COS, "cosl"); + +#if BUILT_FOR_270 + pedantic_lvalues = FALSE; +#endif + + ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node, + FFECOM_f2cINTEGER, + "integer"); + ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node, + FFECOM_f2cADDRESS, + "address"); + ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node, + FFECOM_f2cREAL, + "real"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node, + FFECOM_f2cDOUBLEREAL, + "doublereal"); + ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node, + FFECOM_f2cCOMPLEX, + "complex"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node, + FFECOM_f2cDOUBLECOMPLEX, + "doublecomplex"); + ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node, + FFECOM_f2cLONGINT, + "longint"); + ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node, + FFECOM_f2cLOGICAL, + "logical"); + ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node, + FFECOM_f2cFLAG, + "flag"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node, + FFECOM_f2cFTNLEN, + "ftnlen"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node, + FFECOM_f2cFTNINT, + "ftnint"); + + ffecom_f2c_ftnlen_zero_node + = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node); + + ffecom_f2c_ftnlen_one_node + = convert (ffecom_f2c_ftnlen_type_node, integer_one_node); + + ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0); + TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node; + + ffecom_f2c_ptr_to_ftnlen_type_node + = build_pointer_type (ffecom_f2c_ftnlen_type_node); + + ffecom_f2c_ptr_to_ftnint_type_node + = build_pointer_type (ffecom_f2c_ftnint_type_node); + + ffecom_f2c_ptr_to_integer_type_node + = build_pointer_type (ffecom_f2c_integer_type_node); + + ffecom_f2c_ptr_to_real_type_node + = build_pointer_type (ffecom_f2c_real_type_node); + + ffecom_float_zero_ = build_real (float_type_node, dconst0); + ffecom_double_zero_ = build_real (double_type_node, dconst0); + { + REAL_VALUE_TYPE point_5; + +#ifdef REAL_ARITHMETIC + REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2); +#else + point_5 = .5; +#endif + ffecom_float_half_ = build_real (float_type_node, point_5); + ffecom_double_half_ = build_real (double_type_node, point_5); + } + + /* Do "extern int xargc;". */ + + ffecom_tree_xargc_ = build_decl (VAR_DECL, + get_identifier ("xargc"), + integer_type_node); + DECL_EXTERNAL (ffecom_tree_xargc_) = 1; + TREE_STATIC (ffecom_tree_xargc_) = 1; + TREE_PUBLIC (ffecom_tree_xargc_) = 1; + ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE); + finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE); + +#if 0 /* This is being fixed, and seems to be working now. */ + if ((FLOAT_TYPE_SIZE != 32) + || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32)) + { + warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,", + (int) FLOAT_TYPE_SIZE); + warning ("and pointers are %d bits wide, but g77 doesn't yet work", + (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node)))); + warning ("properly unless they all are 32 bits wide."); + warning ("Please keep this in mind before you report bugs. g77 should"); + warning ("support non-32-bit machines better as of version 0.6."); + } +#endif + +#if 0 /* Code in ste.c that would crash has been commented out. */ + if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) + < TYPE_PRECISION (string_type_node)) + /* I/O will probably crash. */ + warning ("configuration: char * holds %d bits, but ftnlen only %d", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)); +#endif + +#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */ + if (TYPE_PRECISION (ffecom_integer_type_node) + < TYPE_PRECISION (string_type_node)) + /* ASSIGN 10 TO I will crash. */ + warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\ + ASSIGN statement might fail", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_integer_type_node)); +#endif +} + +#endif +/* ffecom_init_2 -- Initialize + + ffecom_init_2(); */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_init_2 () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + assert (ffecom_which_entrypoint_decl_ == NULL_TREE); + + ffecom_master_arglist_ = NULL; + ++ffecom_num_fns_; + ffecom_latest_temp_ = NULL; + ffecom_primary_entry_ = NULL; + ffecom_is_altreturning_ = FALSE; + ffecom_func_result_ = NULL_TREE; + ffecom_multi_retval_ = NULL_TREE; +} + +#endif +/* ffecom_list_expr -- Transform list of exprs into gcc tree + + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_expr(expr); + + List of actual args is transformed into corresponding gcc backend list. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_list_expr (ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + + while (expr != NULL) + { + *plist + = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr), + &length)); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} + +#endif +/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree + + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_ptr_to_expr(expr); + + List of actual args is transformed into corresponding gcc backend list for + use in calling an external procedure (vs. a statement function). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_list_ptr_to_expr (ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + + while (expr != NULL) + { + *plist + = build_tree_list (NULL_TREE, + ffecom_arg_ptr_to_expr (ffebld_head (expr), + &length)); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} + +#endif +/* Obtain gcc's LABEL_DECL tree for label. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_lookup_label (ffelab label) +{ + tree glabel; + + if (ffelab_hook (label) == NULL_TREE) + { + char labelname[16]; + + switch (ffelab_type (label)) + { + case FFELAB_typeLOOPEND: + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label)); + glabel = build_decl (LABEL_DECL, get_identifier (labelname), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + break; + + case FFELAB_typeFORMAT: + push_obstacks_nochange (); + end_temporary_allocation (); + + glabel = build_decl (VAR_DECL, + ffecom_get_invented_identifier + ("__g77_format_%d", NULL, + (int) ffelab_value (label)), + build_type_variant (build_array_type + (char_type_node, + NULL_TREE), + 1, 0)); + TREE_CONSTANT (glabel) = 1; + TREE_STATIC (glabel) = 1; + DECL_CONTEXT (glabel) = 0; + DECL_INITIAL (glabel) = NULL; + make_decl_rtl (glabel, NULL, 0); + expand_decl (glabel); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFELAB_typeANY: + glabel = error_mark_node; + break; + + default: + assert ("bad label type" == NULL); + glabel = NULL; + break; + } + ffelab_set_hook (label, glabel); + } + else + { + glabel = ffelab_hook (label); + } + + return glabel; +} + +#endif +/* Stabilizes the arguments. Don't use this if the lhs and rhs come from + a single source specification (as in the fourth argument of MVBITS). + If the type is NULL_TREE, the type of lhs is used to make the type of + the MODIFY_EXPR. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_modify (tree newtype, tree lhs, + tree rhs) +{ + if (lhs == error_mark_node || rhs == error_mark_node) + return error_mark_node; + + if (newtype == NULL_TREE) + newtype = TREE_TYPE (lhs); + + if (TREE_SIDE_EFFECTS (lhs)) + lhs = stabilize_reference (lhs); + + return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs); +} + +#endif + +/* Register source file name. */ + +void +ffecom_file (char *name) +{ +#if FFECOM_GCC_INCLUDE + ffecom_file_ (name); +#endif +} + +/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed + + ffestorag st; + ffecom_notify_init_storage(st); + + Gets called when all possible units in an aggregate storage area (a LOCAL + with equivalences or a COMMON) have been initialized. The initialization + info either is in ffestorag_init or, if that is NULL, + ffestorag_accretion: + + ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! + + ffestorag_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. + + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. + + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ + +void +ffecom_notify_init_storage (ffestorag st) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ +#endif + + if (ffestorag_init (st) == NULL) + { + init = ffestorag_accretion (st); + assert (init != NULL); + ffestorag_set_accretion (st, NULL); + ffestorag_set_accretes (st, 0); + +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ + size = ffebld_accter_size (init); + ffebit_kill (ffebld_accter_bits (init)); + ffebld_set_op (init, FFEBLD_opARRTER); + ffebld_set_arrter (init, ffebld_accter (init)); + ffebld_arrter_set_size (init, size); +#endif + +#if FFECOM_TWOPASS + ffestorag_set_init (st, init); +#endif + } +#if FFECOM_ONEPASS + else + init = ffestorag_init (st); +#endif + +#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */ + ffestorag_set_init (st, ffebld_new_any ()); + + if (ffebld_op (init) == FFEBLD_opANY) + return; /* Oh, we already did this! */ + +#if FFECOM_targetCURRENT == FFECOM_targetFFE + { + ffesymbol s; + + if (ffestorag_symbol (st) != NULL) + s = ffestorag_symbol (st); + else + s = ffestorag_typesymbol (st); + + fprintf (dmpout, "= initialize_storage \"%s\" ", + (s != NULL) ? ffesymbol_text (s) : "(unnamed)"); + ffebld_dump (init); + fputc ('\n', dmpout); + } +#endif + +#endif /* if FFECOM_ONEPASS */ +} + +/* ffecom_notify_init_symbol -- A symbol is now fully init'ed + + ffesymbol s; + ffecom_notify_init_symbol(s); + + Gets called when all possible units in a symbol (not placed in COMMON + or involved in EQUIVALENCE, unless it as yet has no ffestorag object) + have been initialized. The initialization info either is in + ffesymbol_init or, if that is NULL, ffesymbol_accretion: + + ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! + + ffesymbol_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. + + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. + + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ + +void +ffecom_notify_init_symbol (ffesymbol s) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ +#endif + + if (ffesymbol_storage (s) == NULL) + return; /* Do nothing until COMMON/EQUIVALENCE + possibilities checked. */ + + if ((ffesymbol_init (s) == NULL) + && ((init = ffesymbol_accretion (s)) != NULL)) + { + ffesymbol_set_accretion (s, NULL); + ffesymbol_set_accretes (s, 0); + +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ + size = ffebld_accter_size (init); + ffebit_kill (ffebld_accter_bits (init)); + ffebld_set_op (init, FFEBLD_opARRTER); + ffebld_set_arrter (init, ffebld_accter (init)); + ffebld_arrter_set_size (init, size); +#endif + +#if FFECOM_TWOPASS + ffesymbol_set_init (s, init); +#endif + } +#if FFECOM_ONEPASS + else + init = ffesymbol_init (s); +#endif + +#if FFECOM_ONEPASS + ffesymbol_set_init (s, ffebld_new_any ()); + + if (ffebld_op (init) == FFEBLD_opANY) + return; /* Oh, we already did this! */ + +#if FFECOM_targetCURRENT == FFECOM_targetFFE + fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s)); + ffebld_dump (init); + fputc ('\n', dmpout); +#endif + +#endif /* if FFECOM_ONEPASS */ +} + +/* ffecom_notify_primary_entry -- Learn which is the primary entry point + + ffesymbol s; + ffecom_notify_primary_entry(s); + + Gets called when implicit or explicit PROGRAM statement seen or when + FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary + global symbol that serves as the entry point. */ + +void +ffecom_notify_primary_entry (ffesymbol s) +{ + ffecom_primary_entry_ = s; + ffecom_primary_entry_kind_ = ffesymbol_kind (s); + + if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)) + ffecom_primary_entry_is_proc_ = TRUE; + else + ffecom_primary_entry_is_proc_ = FALSE; + + if (!ffe_is_silent ()) + { + if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM) + fprintf (stderr, "%s:\n", ffesymbol_text (s)); + else + fprintf (stderr, " %s:\n", ffesymbol_text (s)); + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) + { + ffebld list; + ffebld arg; + + for (list = ffesymbol_dummyargs (s); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } +#endif +} + +FILE * +ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) +{ +#if FFECOM_GCC_INCLUDE + return ffecom_open_include_ (name, l, c); +#else + return fopen (name, "r"); +#endif +} + +/* Clean up after making automatically popped call-arg temps. + + Call this in pairs with push_calltemps around calls to + ffecom_arg_ptr_to_expr if the latter might use temporaries. + Any temporaries made within the outermost sequence of + push_calltemps and pop_calltemps, that are marked as "auto-pop" + meaning they won't be explicitly popped (freed), are popped + at this point so they can be reused later. + + NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_ + should come in == 1, and all of the in-use auto-pop temps + should have DECL_CONTEXT (temp->t) == current_function_decl. + Moreover, these temps should _never_ be re-used in future + calls to ffecom_push_tempvar -- since current_function_decl will + never be the same again. + + SO, it could be a minor win in terms of compile time to just + strip these temps off the list. That is, if the above assumptions + are correct, just remove from the list of temps any temp + that is both in-use and has DECL_CONTEXT (temp->t) + == current_function_decl, when called from ffecom_gen_sfuncdef_. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_pop_calltemps () +{ + ffecomTemp_ temp; + + assert (ffecom_pending_calls_ > 0); + + if (--ffecom_pending_calls_ == 0) + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + if (temp->auto_pop) + temp->in_use = FALSE; +} + +#endif +/* Mark latest temp with given tree as no longer in use. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_pop_tempvar (tree t) +{ + ffecomTemp_ temp; + + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + if (temp->in_use && (temp->t == t)) + { + assert (!temp->auto_pop); + temp->in_use = FALSE; + return; + } + else + assert (temp->t != t); + + assert ("couldn't ffecom_pop_tempvar!" != NULL); +} + +#endif +/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front + + tree t; + ffebld expr; // FFE expression. + tree = ffecom_ptr_to_expr(expr); + + Like ffecom_expr, but sticks address-of in front of most things. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_ptr_to_expr (ffebld expr) +{ + tree item; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffesymbol s; + + assert (expr != NULL); + + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + ffecomGfrt ix; + + ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr)); + assert (ix != FFECOM_gfrt); + if ((item = ffecom_gfrt_[ix]) == NULL_TREE) + { + ffecom_make_gfrt_ (ix); + item = ffecom_gfrt_[ix]; + } + } + else + { + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + } + assert (item != NULL); + if (item == error_mark_node) + return item; + if (!ffesymbol_hook (s).addr) + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; + tree array; + int i; + + item = ffecom_ptr_to_expr (ffebld_left (expr)); + + if (item == error_mark_node) + return item; + + if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) + && !mark_addressable (item)) + return error_mark_node; /* Make sure non-const ref is to + non-reg. */ + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + { + item + = ffecom_2 (PLUS_EXPR, + build_pointer_type (TREE_TYPE (array)), + item, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + } + } + return item; + + case FFEBLD_opCONTER: + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + item = ffecom_constantunion (&ffebld_constant_union + (ffebld_conter (expr)), bt, kt, + ffecom_tree_type[bt][kt]); + if (item == error_mark_node) + return error_mark_node; + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + + case FFEBLD_opANY: + return error_mark_node; + + default: + assert (ffecom_pending_calls_ > 0); + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + item = ffecom_expr (expr); + if (item == error_mark_node) + return error_mark_node; + + /* The back end currently optimizes a bit too zealously for us, in that + we fail JCB001 if the following block of code is omitted. It checks + to see if the transformed expression is a symbol or array reference, + and encloses it in a SAVE_EXPR if that is the case. */ + + STRIP_NOPS (item); + if ((TREE_CODE (item) == VAR_DECL) + || (TREE_CODE (item) == PARM_DECL) + || (TREE_CODE (item) == RESULT_DECL) + || (TREE_CODE (item) == INDIRECT_REF) + || (TREE_CODE (item) == ARRAY_REF) + || (TREE_CODE (item) == COMPONENT_REF) +#ifdef OFFSET_REF + || (TREE_CODE (item) == OFFSET_REF) +#endif + || (TREE_CODE (item) == BUFFER_REF) + || (TREE_CODE (item) == REALPART_EXPR) + || (TREE_CODE (item) == IMAGPART_EXPR)) + { + item = ffecom_save_tree (item); + } + + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + } + + assert ("fall-through error" == NULL); + return error_mark_node; +} + +#endif +/* Prepare to make call-arg temps. + + Call this in pairs with pop_calltemps around calls to + ffecom_arg_ptr_to_expr if the latter might use temporaries. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_push_calltemps () +{ + ffecom_pending_calls_++; +} + +#endif +/* Obtain a temp var with given data type. + + Returns a VAR_DECL tree of a currently (that is, at the current + statement being compiled) not in use and having the given data type, + making a new one if necessary. size is FFETARGET_charactersizeNONE + for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is + -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if + ffecom_pop_tempvar won't be called, meaning temp will be freed + when #pending calls goes to zero. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements, + bool auto_pop) +{ + ffecomTemp_ temp; + int yes; + tree t; + static int mynumber; + + assert (!auto_pop || (ffecom_pending_calls_ > 0)); + + if (type == error_mark_node) + return error_mark_node; + + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + { + if (temp->in_use + || (temp->type != type) + || (temp->size != size) + || (temp->elements != elements) + || (DECL_CONTEXT (temp->t) != current_function_decl)) + continue; + + temp->in_use = TRUE; + temp->auto_pop = auto_pop; + return temp->t; + } + + /* Create a new temp. */ + + yes = suspend_momentary (); + + if (size != FFETARGET_charactersizeNONE) + type = build_array_type (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + build_int_2 (size, 0))); + if (elements != -1) + type = build_array_type (type, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 (elements - 1, + 0))); + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_expr_%d", NULL, + mynumber++), + type); + { /* ~~~~ kludge alert here!!! else temp gets reused outside + a compound-statement sequence.... */ + extern tree sequence_rtl_expr; + tree back_end_bug = sequence_rtl_expr; + + sequence_rtl_expr = NULL_TREE; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + sequence_rtl_expr = back_end_bug; + } + + resume_momentary (yes); + + temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_", + sizeof (*temp)); + + temp->next = ffecom_latest_temp_; + temp->type = type; + temp->t = t; + temp->size = size; + temp->elements = elements; + temp->in_use = TRUE; + temp->auto_pop = auto_pop; + + ffecom_latest_temp_ = temp; + + return t; +} + +#endif +/* ffecom_return_expr -- Returns return-value expr given alt return expr + + tree rtn; // NULL_TREE means use expand_null_return() + ffebld expr; // NULL if no alt return expr to RETURN stmt + rtn = ffecom_return_expr(expr); + + Based on the program unit type and other info (like return function + type, return master function type when alternate ENTRY points, + whether subroutine has any alternate RETURN points, etc), returns the + appropriate expression to be returned to the caller, or NULL_TREE + meaning no return value or the caller expects it to be returned somewhere + else (which is handled by other parts of this module). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_return_expr (ffebld expr) +{ + tree rtn; + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindPROGRAM: + case FFEINFO_kindBLOCKDATA: + rtn = NULL_TREE; + break; + + case FFEINFO_kindSUBROUTINE: + if (!ffecom_is_altreturning_) + rtn = NULL_TREE; /* No alt returns, never an expr. */ + else if (expr == NULL) + rtn = integer_zero_node; + else + rtn = ffecom_expr (expr); + break; + + case FFEINFO_kindFUNCTION: + if ((ffecom_multi_retval_ != NULL_TREE) + || (ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCHARACTER) + || ((ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCOMPLEX) + && (ffecom_num_entrypoints_ == 0) + && ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Value is returned by direct assignment + into (implicit) dummy. */ + rtn = NULL_TREE; + break; + } + rtn = ffecom_func_result_; +#if 0 + /* Spurious error if RETURN happens before first reference! So elide + this code. In particular, for debugging registry, rtn should always + be non-null after all, but TREE_USED won't be set until we encounter + a reference in the code. Perfectly okay (but weird) code that, + e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in + this diagnostic for no reason. Have people use -O -Wuninitialized + and leave it to the back end to find obviously weird cases. */ + + /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid + situation; if the return value has never been referenced, it won't + have a tree under 2pass mode. */ + if ((rtn == NULL_TREE) + || !TREE_USED (rtn)) + { + ffebad_start (FFEBAD_RETURN_VALUE_UNSET); + ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_), + ffesymbol_where_column (ffecom_primary_entry_)); + ffebad_string (ffesymbol_text (ffesymbol_funcresult + (ffecom_primary_entry_))); + ffebad_finish (); + } +#endif + break; + + default: + assert ("bad unit kind" == NULL); + case FFEINFO_kindANY: + rtn = error_mark_node; + break; + } + + return rtn; +} + +#endif +/* Do save_expr only if tree is not error_mark_node. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree ffecom_save_tree (tree t) +{ + return save_expr (t); +} +#endif + +/* Public entry point for front end to access start_decl. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_start_decl (tree decl, bool is_initialized) +{ + DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; + return start_decl (decl, FALSE); +} + +#endif +/* ffecom_sym_commit -- Symbol's state being committed to reality + + ffesymbol s; + ffecom_sym_commit(s); + + Does whatever the backend needs when a symbol is committed after having + been backtrackable for a period of time. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_sym_commit (ffesymbol s UNUSED) +{ + assert (!ffesymbol_retractable ()); +} + +#endif +/* ffecom_sym_end_transition -- Perform end transition on all symbols + + ffecom_sym_end_transition(); + + Does backend-specific stuff and also calls ffest_sym_end_transition + to do the necessary FFE stuff. + + Backtracking is never enabled when this fn is called, so don't worry + about it. */ + +ffesymbol +ffecom_sym_end_transition (ffesymbol s) +{ + ffestorag st; + + assert (!ffesymbol_retractable ()); + + s = ffest_sym_end_transition (s); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA) + && (ffesymbol_where (s) == FFEINFO_whereGLOBAL)) + { + ffecom_list_blockdata_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_blockdata_); + } +#endif + + /* This is where we finally notice that a symbol has partial initialization + and finalize it. */ + + if (ffesymbol_accretion (s) != NULL) + { + assert (ffesymbol_init (s) == NULL); + ffecom_notify_init_symbol (s); + } + else if (((st = ffesymbol_storage (s)) != NULL) + && ((st = ffestorag_parent (st)) != NULL) + && (ffestorag_accretion (st) != NULL)) + { + assert (ffestorag_init (st) == NULL); + ffecom_notify_init_storage (st); + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON) + && (ffesymbol_where (s) == FFEINFO_whereLOCAL) + && (ffesymbol_storage (s) != NULL)) + { + ffecom_list_common_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_common_); + } +#endif + + return s; +} + +/* ffecom_sym_exec_transition -- Perform exec transition on all symbols + + ffecom_sym_exec_transition(); + + Does backend-specific stuff and also calls ffest_sym_exec_transition + to do the necessary FFE stuff. + + See the long-winded description in ffecom_sym_learned for info + on handling the situation where backtracking is inhibited. */ + +ffesymbol +ffecom_sym_exec_transition (ffesymbol s) +{ + s = ffest_sym_exec_transition (s); + + return s; +} + +/* ffecom_sym_learned -- Initial or more info gained on symbol after exec + + ffesymbol s; + s = ffecom_sym_learned(s); + + Called when a new symbol is seen after the exec transition or when more + info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when + it arrives here is that all its latest info is updated already, so its + state may be UNCERTAIN or UNDERSTOOD, it might already have the hook + field filled in if its gone through here or exec_transition first, and + so on. + + The backend probably wants to check ffesymbol_retractable() to see if + backtracking is in effect. If so, the FFE's changes to the symbol may + be retracted (undone) or committed (ratified), at which time the + appropriate ffecom_sym_retract or _commit function will be called + for that function. + + If the backend has its own backtracking mechanism, great, use it so that + committal is a simple operation. Though it doesn't make much difference, + I suppose: the reason for tentative symbol evolution in the FFE is to + enable error detection in weird incorrect statements early and to disable + incorrect error detection on a correct statement. The backend is not + likely to introduce any information that'll get involved in these + considerations, so it is probably just fine that the implementation + model for this fn and for _exec_transition is to not do anything + (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE + and instead wait until ffecom_sym_commit is called (which it never + will be as long as we're using ambiguity-detecting statement analysis in + the FFE, which we are initially to shake out the code, but don't depend + on this), otherwise go ahead and do whatever is needed. + + In essence, then, when this fn and _exec_transition get called while + backtracking is enabled, a general mechanism would be to flag which (or + both) of these were called (and in what order? neat question as to what + might happen that I'm too lame to think through right now) and then when + _commit is called reproduce the original calling sequence, if any, for + the two fns (at which point backtracking will, of course, be disabled). */ + +ffesymbol +ffecom_sym_learned (ffesymbol s) +{ + ffestorag_exec_layout (s); + + return s; +} + +/* ffecom_sym_retract -- Symbol's state being retracted from reality + + ffesymbol s; + ffecom_sym_retract(s); + + Does whatever the backend needs when a symbol is retracted after having + been backtrackable for a period of time. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_sym_retract (ffesymbol s UNUSED) +{ + assert (!ffesymbol_retractable ()); + +#if 0 /* GCC doesn't commit any backtrackable sins, + so nothing needed here. */ + switch (ffesymbol_hook (s).state) + { + case 0: /* nothing happened yet. */ + break; + + case 1: /* exec transition happened. */ + break; + + case 2: /* learned happened. */ + break; + + case 3: /* learned then exec. */ + break; + + case 4: /* exec then learned. */ + break; + + default: + assert ("bad hook state" == NULL); + break; + } +#endif +} + +#endif +/* Create temporary gcc label. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_temp_label () +{ + tree glabel; + static int mynumber = 0; + + glabel = build_decl (LABEL_DECL, + ffecom_get_invented_identifier ("__g77_label_%d", + NULL, + mynumber++), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + + return glabel; +} + +#endif +/* Return an expression that is usable as an arg in a conditional context + (IF, DO WHILE, .NOT., and so on). + + Use the one provided for the back end as of >2.6.0. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_truth_value (tree expr) +{ + return truthvalue_conversion (expr); +} + +#endif +/* Return the inversion of a truth value (the inversion of what + ffecom_truth_value builds). + + Apparently invert_truthvalue, which is properly in the back end, is + enough for now, so just use it. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_truth_value_invert (tree expr) +{ + return invert_truthvalue (ffecom_truth_value (expr)); +} + +#endif +/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points + + If the PARM_DECL already exists, return it, else create it. It's an + integer_type_node argument for the master function that implements a + subroutine or function with more than one entrypoint and is bound at + run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for + first ENTRY statement, and so on). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_which_entrypoint_decl () +{ + assert (ffecom_which_entrypoint_decl_ != NULL_TREE); + + return ffecom_which_entrypoint_decl_; +} + +#endif + +/* The following sections consists of private and public functions + that have the same names and perform roughly the same functions + as counterparts in the C front end. Changes in the C front end + might affect how things should be done here. Only functions + needed by the back end should be public here; the rest should + be private (static in the C sense). Functions needed by other + g77 front-end modules should be accessed by them via public + ffecom_* names, which should themselves call private versions + in this section so the private versions are easy to recognize + when upgrading to a new gcc and finding interesting changes + in the front end. + + Functions named after rule "foo:" in c-parse.y are named + "bison_rule_foo_" so they are easy to find. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + +static void +bison_rule_compstmt_ () +{ + emit_line_note (input_filename, lineno); + expand_end_bindings (getdecls (), 1, 1); + poplevel (1, 1, 0); + pop_momentary (); +} + +static void +bison_rule_pushlevel_ () +{ + emit_line_note (input_filename, lineno); + pushlevel (0); + clear_last_expr (); + push_momentary (); + expand_start_bindings (0); +} + +/* Return a definition for a builtin function named NAME and whose data type + is TYPE. TYPE should be a function type with argument types. + FUNCTION_CODE tells later passes how to compile calls to this function. + See tree.h for its possible values. + + If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, + the name to be called if we can't opencode the function. */ + +static tree +builtin_function (char *name, tree type, + enum built_in_function function_code, char *library_name) +{ + tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + if (library_name) + DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); + make_decl_rtl (decl, NULL_PTR, 1); + pushdecl (decl); + if (function_code != NOT_BUILT_IN) + { + DECL_BUILT_IN (decl) = 1; + DECL_FUNCTION_CODE (decl) = function_code; + } + + return decl; +} + +/* Handle when a new declaration NEWDECL + has the same name as an old one OLDDECL + in the same binding contour. + Prints an error message if appropriate. + + If safely possible, alter OLDDECL to look like NEWDECL, and return 1. + Otherwise, return 0. */ + +static int +duplicate_decls (tree newdecl, tree olddecl) +{ + int types_match = 1; + int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_INITIAL (newdecl) != 0); + tree oldtype = TREE_TYPE (olddecl); + tree newtype = TREE_TYPE (newdecl); + + if (olddecl == newdecl) + return 1; + + if (TREE_CODE (newtype) == ERROR_MARK + || TREE_CODE (oldtype) == ERROR_MARK) + types_match = 0; + + /* New decl is completely inconsistent with the old one => + tell caller to replace the old one. + This is always an error except in the case of shadowing a builtin. */ + if (TREE_CODE (olddecl) != TREE_CODE (newdecl)) + return 0; + + /* For real parm decl following a forward decl, + return 1 so old decl will be reused. */ + if (types_match && TREE_CODE (newdecl) == PARM_DECL + && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl)) + return 1; + + /* The new declaration is the same kind of object as the old one. + The declarations may partially match. Print warnings if they don't + match enough. Ultimately, copy most of the information from the new + decl to the old one, and keep using the old one. */ + + if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl)) + { + /* A function declaration for a built-in function. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* Accept the return type of the new declaration if same modes. */ + tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl)); + tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl)); + + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the + permanent one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } + + if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype)) + { + /* Function types may be shared, so we can't just modify + the return type of olddecl's function type. */ + tree newtype + = build_function_type (newreturntype, + TYPE_ARG_TYPES (TREE_TYPE (olddecl))); + + types_match = 1; + if (types_match) + TREE_TYPE (olddecl) = newtype; + } + + pop_obstacks (); + } + if (!types_match) + return 0; + } + else if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_SOURCE_LINE (olddecl) == 0) + { + /* A function declaration for a predeclared function + that isn't actually built in. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* If the types don't match, preserve volatility indication. + Later on, we will discard everything else about the + default declaration. */ + TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); + } + } + + /* Copy all the DECL_... slots specified in the new decl + except for any that we copy here from the old type. + + Past this point, we don't change OLDTYPE and NEWTYPE + even if we change the types of NEWDECL and OLDDECL. */ + + if (types_match) + { + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the permanent + one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } + + /* Merge the data types specified in the two decls. */ + if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl)) + TREE_TYPE (newdecl) + = TREE_TYPE (olddecl) + = TREE_TYPE (newdecl); + + /* Lay the type out, unless already done. */ + if (oldtype != TREE_TYPE (newdecl)) + { + if (TREE_TYPE (newdecl) != error_mark_node) + layout_type (TREE_TYPE (newdecl)); + if (TREE_CODE (newdecl) != FUNCTION_DECL + && TREE_CODE (newdecl) != TYPE_DECL + && TREE_CODE (newdecl) != CONST_DECL) + layout_decl (newdecl, 0); + } + else + { + /* Since the type is OLDDECL's, make OLDDECL's size go with. */ + DECL_SIZE (newdecl) = DECL_SIZE (olddecl); + if (TREE_CODE (olddecl) != FUNCTION_DECL) + if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) + DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); + } + + /* Keep the old rtl since we can safely use it. */ + DECL_RTL (newdecl) = DECL_RTL (olddecl); + + /* Merge the type qualifiers. */ + if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl) + && !TREE_THIS_VOLATILE (newdecl)) + TREE_THIS_VOLATILE (olddecl) = 0; + if (TREE_READONLY (newdecl)) + TREE_READONLY (olddecl) = 1; + if (TREE_THIS_VOLATILE (newdecl)) + { + TREE_THIS_VOLATILE (olddecl) = 1; + if (TREE_CODE (newdecl) == VAR_DECL) + make_var_volatile (newdecl); + } + + /* Keep source location of definition rather than declaration. + Likewise, keep decl at outer scope. */ + if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0) + || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0)) + { + DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl); + DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl); + + if (DECL_CONTEXT (olddecl) == 0 + && TREE_CODE (newdecl) != FUNCTION_DECL) + DECL_CONTEXT (newdecl) = 0; + } + + /* Merge the unused-warning information. */ + if (DECL_IN_SYSTEM_HEADER (olddecl)) + DECL_IN_SYSTEM_HEADER (newdecl) = 1; + else if (DECL_IN_SYSTEM_HEADER (newdecl)) + DECL_IN_SYSTEM_HEADER (olddecl) = 1; + + /* Merge the initialization information. */ + if (DECL_INITIAL (newdecl) == 0) + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + + /* Merge the section attribute. + We want to issue an error if the sections conflict but that must be + done later in decl_attributes since we are called before attributes + are assigned. */ + if (DECL_SECTION_NAME (newdecl) == NULL_TREE) + DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl); + +#if BUILT_FOR_270 + if (TREE_CODE (newdecl) == FUNCTION_DECL) + { + DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); + DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); + } +#endif + + pop_obstacks (); + } + /* If cannot merge, then use the new type and qualifiers, + and don't preserve the old rtl. */ + else + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + TREE_READONLY (olddecl) = TREE_READONLY (newdecl); + TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl); + TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl); + } + + /* Merge the storage class information. */ + /* For functions, static overrides non-static. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL) + { + TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl); + /* This is since we don't automatically + copy the attributes of NEWDECL into OLDDECL. */ + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + /* If this clears `static', clear it in the identifier too. */ + if (! TREE_PUBLIC (olddecl)) + TREE_PUBLIC (DECL_NAME (olddecl)) = 0; + } + if (DECL_EXTERNAL (newdecl)) + { + TREE_STATIC (newdecl) = TREE_STATIC (olddecl); + DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl); + /* An extern decl does not override previous storage class. */ + TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); + } + else + { + TREE_STATIC (olddecl) = TREE_STATIC (newdecl); + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + } + + /* If either decl says `inline', this fn is inline, + unless its definition was passed already. */ + if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0) + DECL_INLINE (olddecl) = 1; + DECL_INLINE (newdecl) = DECL_INLINE (olddecl); + + /* Get rid of any built-in function if new arg types don't match it + or if we have a function definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl) + && (!types_match || new_is_definition)) + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + DECL_BUILT_IN (olddecl) = 0; + } + + /* If redeclaring a builtin function, and not a definition, + it stays built in. + Also preserve various other info from the definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition) + { + if (DECL_BUILT_IN (olddecl)) + { + DECL_BUILT_IN (newdecl) = 1; + DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl); + } + else + DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl); + + DECL_RESULT (newdecl) = DECL_RESULT (olddecl); + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl); + DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl); + } + + /* Copy most of the decl-specific fields of NEWDECL into OLDDECL. + But preserve olddecl's DECL_UID. */ + { + register unsigned olddecl_uid = DECL_UID (olddecl); + + bcopy ((char *) newdecl + sizeof (struct tree_common), + (char *) olddecl + sizeof (struct tree_common), + sizeof (struct tree_decl) - sizeof (struct tree_common)); + DECL_UID (olddecl) = olddecl_uid; + } + + return 1; +} + +/* Finish processing of a declaration; + install its initial value. + If the length of an array type is not known before, + it must be determined now, from the initial value, or it is an error. */ + +static void +finish_decl (tree decl, tree init, bool is_top_level) +{ + register tree type = TREE_TYPE (decl); + int was_incomplete = (DECL_SIZE (decl) == 0); + int temporary = allocation_temporary_p (); + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; + + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); + + if (TREE_CODE (decl) == PARM_DECL) + assert (init == NULL_TREE); + /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it + overlaps DECL_ARG_TYPE. */ + else if (init == NULL_TREE) + assert (DECL_INITIAL (decl) == NULL_TREE); + else + assert (DECL_INITIAL (decl) == error_mark_node); + + if (init != NULL_TREE) + { + if (TREE_CODE (decl) != TYPE_DECL) + DECL_INITIAL (decl) = init; + else + { + /* typedef foo = bar; store the type of bar as the type of foo. */ + TREE_TYPE (decl) = TREE_TYPE (init); + DECL_INITIAL (decl) = init = 0; + } + } + + /* Pop back to the obstack that is current for this binding level. This is + because MAXINDEX, rtl, etc. to be made below must go in the permanent + obstack. But don't discard the temporary data yet. */ + pop_obstacks (); + + /* Deduce size of array from initialization, if not already known */ + + if (TREE_CODE (type) == ARRAY_TYPE + && TYPE_DOMAIN (type) == 0 + && TREE_CODE (decl) != TYPE_DECL) + { + assert (top_level); + assert (was_incomplete); + + layout_decl (decl, 0); + } + + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == NULL_TREE + && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + layout_decl (decl, 0); + + if (DECL_SIZE (decl) == NULL_TREE + && (TREE_STATIC (decl) + ? + /* A static variable with an incomplete type is an error if it is + initialized. Also if it is not file scope. Otherwise, let it + through, but if it is not `extern' then it may cause an error + message later. */ + (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0) + : + /* An automatic variable with an incomplete type is an error. */ + !DECL_EXTERNAL (decl))) + { + assert ("storage size not known" == NULL); + abort (); + } + + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && (DECL_SIZE (decl) != 0) + && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) + { + assert ("storage size not constant" == NULL); + abort (); + } + } + + /* Output the assembler code and/or RTL code for variables and functions, + unless the type is an undefined structure or union. If not, it will get + done when the type is completed. */ + + if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) + { + rest_of_decl_compilation (decl, NULL, + DECL_CONTEXT (decl) == 0, + 0); + + if (DECL_CONTEXT (decl) != 0) + { + /* Recompute the RTL of a local array now if it used to be an + incomplete type. */ + if (was_incomplete + && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) + { + /* If we used it already as memory, it must stay in memory. */ + TREE_ADDRESSABLE (decl) = TREE_USED (decl); + /* If it's still incomplete now, no init will save it. */ + if (DECL_SIZE (decl) == 0) + DECL_INITIAL (decl) = 0; + expand_decl (decl); + } + /* Compute and store the initial value. */ + if (TREE_CODE (decl) != FUNCTION_DECL) + expand_decl_init (decl); + } + } + else if (TREE_CODE (decl) == TYPE_DECL) + { + rest_of_decl_compilation (decl, NULL_PTR, + DECL_CONTEXT (decl) == 0, + 0); + } + + /* This test used to include TREE_PERMANENT, however, we have the same + problem with initializers at the function level. Such initializers get + saved until the end of the function on the momentary_obstack. */ + if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) + && temporary + /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with + DECL_ARG_TYPE. */ + && TREE_CODE (decl) != PARM_DECL) + { + /* We need to remember that this array HAD an initialization, but + discard the actual temporary nodes, since we can't have a permanent + node keep pointing to them. */ + /* We make an exception for inline functions, since it's normal for a + local extern redeclaration of an inline function to have a copy of + the top-level decl's DECL_INLINE. */ + if ((DECL_INITIAL (decl) != 0) + && (DECL_INITIAL (decl) != error_mark_node)) + { + /* If this is a const variable, then preserve the + initializer instead of discarding it so that we can optimize + references to it. */ + /* This test used to include TREE_STATIC, but this won't be set + for function level initializers. */ + if (TREE_READONLY (decl)) + { + preserve_initializer (); + /* Hack? Set the permanent bit for something that is + permanent, but not on the permenent obstack, so as to + convince output_constant_def to make its rtl on the + permanent obstack. */ + TREE_PERMANENT (DECL_INITIAL (decl)) = 1; + + /* The initializer and DECL must have the same (or equivalent + types), but if the initializer is a STRING_CST, its type + might not be on the right obstack, so copy the type + of DECL. */ + TREE_TYPE (DECL_INITIAL (decl)) = type; + } + else + DECL_INITIAL (decl) = error_mark_node; + } + } + + /* If requested, warn about definitions of large data objects. */ + + if (warn_larger_than + && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) + && !DECL_EXTERNAL (decl)) + { + register tree decl_size = DECL_SIZE (decl); + + if (decl_size && TREE_CODE (decl_size) == INTEGER_CST) + { + unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT; + + if (units > larger_than_size) + warning_with_decl (decl, "size of `%s' is %u bytes", units); + } + } + + /* If we have gone back from temporary to permanent allocation, actually + free the temporary space that we no longer need. */ + if (temporary && !allocation_temporary_p ()) + permanent_allocation (0); + + /* At the end of a declaration, throw away any variable type sizes of types + defined inside that declaration. There is no use computing them in the + following function definition. */ + if (current_binding_level == global_binding_level) + get_pending_sizes (); +} + +/* Finish up a function declaration and compile that function + all the way to assembler language output. The free the storage + for the function definition. + + This is called after parsing the body of the function definition. + + NESTED is nonzero if the function being finished is nested in another. */ + +static void +finish_function (int nested) +{ + register tree fndecl = current_function_decl; + + assert (fndecl != NULL_TREE); + if (nested) + assert (DECL_CONTEXT (fndecl) != NULL_TREE); + else + assert (DECL_CONTEXT (fndecl) == NULL_TREE); + +/* TREE_READONLY (fndecl) = 1; + This caused &foo to be of type ptr-to-const-function + which then got a warning when stored in a ptr-to-function variable. */ + + poplevel (1, 0, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + /* Must mark the RESULT_DECL as being in this function. */ + + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + /* Obey `register' declarations if `setjmp' is called in this fn. */ + /* Generate rtl for function exit. */ + expand_function_end (input_filename, lineno, 0); + + /* So we can tell if jump_optimize sets it to 1. */ + can_reach_end = 0; + + /* Run the optimizers and output the assembler code for this function. */ + rest_of_compilation (fndecl); + + /* Free all the tree nodes making up this function. */ + /* Switch back to allocating nodes permanently until we start another + function. */ + if (!nested) + permanent_allocation (1); + + if (DECL_SAVED_INSNS (fndecl) == 0 && !nested) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + /* For a nested function, this is done in pop_f_function_context. */ + /* If rest_of_compilation set this to 0, leave it 0. */ + if (DECL_INITIAL (fndecl) != 0) + DECL_INITIAL (fndecl) = error_mark_node; + DECL_ARGUMENTS (fndecl) = 0; + } + + if (!nested) + { + /* Let the error reporting routines know that we're outside a function. + For a nested function, this value is used in pop_c_function_context + and then reset via pop_function_context. */ + ffecom_outer_function_decl_ = current_function_decl = NULL; + } +} + +/* Plug-in replacement for identifying the name of a decl and, for a + function, what we call it in diagnostics. For now, "program unit" + should suffice, since it's a bit of a hassle to figure out which + of several kinds of things it is. Note that it could conceivably + be a statement function, which probably isn't really a program unit + per se, but if that comes up, it should be easy to check (being a + nested function and all). */ + +static char * +lang_printable_name (tree decl, char **kind) +{ + *kind = "program unit"; + return IDENTIFIER_POINTER (DECL_NAME (decl)); +} + +/* g77's function to print out name of current function that caused + an error. */ + +#if BUILT_FOR_270 +void +lang_print_error_function (file) + char *file; +{ + static ffesymbol last_s = NULL; + ffesymbol s; + char *kind; + + if (ffecom_primary_entry_ == NULL) + { + s = NULL; + kind = NULL; + } + else if (ffecom_nested_entry_ == NULL) + { + s = ffecom_primary_entry_; + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindFUNCTION: + kind = "function"; + break; + + case FFEINFO_kindSUBROUTINE: + kind = "subroutine"; + break; + + case FFEINFO_kindPROGRAM: + kind = "program"; + break; + + case FFEINFO_kindBLOCKDATA: + kind = "block-data"; + break; + + default: + kind = ffeinfo_kind_message (ffesymbol_kind (s)); + break; + } + } + else + { + s = ffecom_nested_entry_; + kind = "statement function"; + } + + if (last_s != s) + { + if (file) + fprintf (stderr, "%s: ", file); + + if (s == NULL) + fprintf (stderr, "Outside of any program unit:\n"); + else + { + char *name = ffesymbol_text (s); + + fprintf (stderr, "In %s `%s':\n", kind, name); + } + + last_s = s; + } +} +#endif + +/* Similar to `lookup_name' but look only at current binding level. */ + +static tree +lookup_name_current_level (tree name) +{ + register tree t; + + if (current_binding_level == global_binding_level) + return IDENTIFIER_GLOBAL_VALUE (name); + + if (IDENTIFIER_LOCAL_VALUE (name) == 0) + return 0; + + for (t = current_binding_level->names; t; t = TREE_CHAIN (t)) + if (DECL_NAME (t) == name) + break; + + return t; +} + +/* Create a new `struct binding_level'. */ + +static struct binding_level * +make_binding_level () +{ + /* NOSTRICT */ + return (struct binding_level *) xmalloc (sizeof (struct binding_level)); +} + +/* Save and restore the variables in this file and elsewhere + that keep track of the progress of compilation of the current function. + Used for nested functions. */ + +struct f_function +{ + struct f_function *next; + tree named_labels; + tree shadowed_labels; + struct binding_level *binding_level; +}; + +struct f_function *f_function_chain; + +/* Restore the variables used during compilation of a C function. */ + +static void +pop_f_function_context () +{ + struct f_function *p = f_function_chain; + tree link; + + /* Bring back all the labels that were shadowed. */ + for (link = shadowed_labels; link; link = TREE_CHAIN (link)) + if (DECL_NAME (TREE_VALUE (link)) != 0) + IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) + = TREE_VALUE (link); + + if (DECL_SAVED_INSNS (current_function_decl) == 0) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + DECL_INITIAL (current_function_decl) = error_mark_node; + DECL_ARGUMENTS (current_function_decl) = 0; + } + + pop_function_context (); + + f_function_chain = p->next; + + named_labels = p->named_labels; + shadowed_labels = p->shadowed_labels; + current_binding_level = p->binding_level; + + free (p); +} + +/* Save and reinitialize the variables + used during compilation of a C function. */ + +static void +push_f_function_context () +{ + struct f_function *p + = (struct f_function *) xmalloc (sizeof (struct f_function)); + + push_function_context (); + + p->next = f_function_chain; + f_function_chain = p; + + p->named_labels = named_labels; + p->shadowed_labels = shadowed_labels; + p->binding_level = current_binding_level; +} + +static void +push_parm_decl (tree parm) +{ + int old_immediate_size_expand = immediate_size_expand; + + /* Don't try computing parm sizes now -- wait till fn is called. */ + + immediate_size_expand = 0; + + push_obstacks_nochange (); + + /* Fill in arg stuff. */ + + DECL_ARG_TYPE (parm) = TREE_TYPE (parm); + DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm); + TREE_READONLY (parm) = 1; /* All implementation args are read-only. */ + + parm = pushdecl (parm); + + immediate_size_expand = old_immediate_size_expand; + + finish_decl (parm, NULL_TREE, FALSE); +} + +/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */ + +static tree +pushdecl_top_level (x) + tree x; +{ + register tree t; + register struct binding_level *b = current_binding_level; + register tree f = current_function_decl; + + current_binding_level = global_binding_level; + current_function_decl = NULL_TREE; + t = pushdecl (x); + current_binding_level = b; + current_function_decl = f; + return t; +} + +/* Store the list of declarations of the current level. + This is done for the parameter declarations of a function being defined, + after they are modified in the light of any missing parameters. */ + +static tree +storedecls (decls) + tree decls; +{ + return current_binding_level->names = decls; +} + +/* Store the parameter declarations into the current function declaration. + This is called after parsing the parameter declarations, before + digesting the body of the function. + + For an old-style definition, modify the function's type + to specify at least the number of arguments. */ + +static void +store_parm_decls (int is_main_program UNUSED) +{ + register tree fndecl = current_function_decl; + + /* This is a chain of PARM_DECLs from old-style parm declarations. */ + DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ())); + + /* Initialize the RTL code for the function. */ + + init_function_start (fndecl, input_filename, lineno); + + /* Set up parameters and prepare for return, for the function. */ + + expand_function_start (fndecl, 0); +} + +static tree +start_decl (tree decl, bool is_top_level) +{ + register tree tem; + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; + + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); + + /* The corresponding pop_obstacks is in finish_decl. */ + push_obstacks_nochange (); + + if (DECL_INITIAL (decl) != NULL_TREE) + { + assert (DECL_INITIAL (decl) == error_mark_node); + assert (!DECL_EXTERNAL (decl)); + } + else if (top_level) + assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1); + + /* For Fortran, we by default put things in .common when possible. */ + DECL_COMMON (decl) = 1; + + /* Add this decl to the current binding level. TEM may equal DECL or it may + be a previous decl of the same name. */ + if (is_top_level) + tem = pushdecl_top_level (decl); + else + tem = pushdecl (decl); + + /* For a local variable, define the RTL now. */ + if (!top_level + /* But not if this is a duplicate decl and we preserved the rtl from the + previous one (which may or may not happen). */ + && DECL_RTL (tem) == 0) + { + if (TYPE_SIZE (TREE_TYPE (tem)) != 0) + expand_decl (tem); + else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE + && DECL_INITIAL (tem) != 0) + expand_decl (tem); + } + + if (DECL_INITIAL (tem) != NULL_TREE) + { + /* When parsing and digesting the initializer, use temporary storage. + Do this even if we will ignore the value. */ + if (at_top_level) + temporary_allocation (); + } + + return tem; +} + +/* Create the FUNCTION_DECL for a function definition. + DECLSPECS and DECLARATOR are the parts of the declaration; + they describe the function's name and the type it returns, + but twisted together in a fashion that parallels the syntax of C. + + This function creates a binding context for the function body + as well as setting up the FUNCTION_DECL in current_function_decl. + + Returns 1 on success. If the DECLARATOR is not suitable for a function + (it defines a datum instead), we return 0, which tells + yyparse to report a parse error. + + NESTED is nonzero for a function nested within another function. */ + +static void +start_function (tree name, tree type, int nested, int public) +{ + tree decl1; + tree restype; + int old_immediate_size_expand = immediate_size_expand; + + named_labels = 0; + shadowed_labels = 0; + + /* Don't expand any sizes in the return type of the function. */ + immediate_size_expand = 0; + + if (nested) + { + assert (!public); + assert (current_function_decl != NULL_TREE); + assert (DECL_CONTEXT (current_function_decl) == NULL_TREE); + } + else + { + assert (current_function_decl == NULL_TREE); + } + + decl1 = build_decl (FUNCTION_DECL, + name, + type); + TREE_PUBLIC (decl1) = public ? 1 : 0; + if (nested) + DECL_INLINE (decl1) = 1; + TREE_STATIC (decl1) = 1; + DECL_EXTERNAL (decl1) = 0; + + announce_function (decl1); + + /* Make the init_value nonzero so pushdecl knows this is not tentative. + error_mark_node is replaced below (in poplevel) with the BLOCK. */ + DECL_INITIAL (decl1) = error_mark_node; + + /* Record the decl so that the function name is defined. If we already have + a decl for this name, and it is a FUNCTION_DECL, use the old decl. */ + + current_function_decl = pushdecl (decl1); + if (!nested) + ffecom_outer_function_decl_ = current_function_decl; + + pushlevel (0); + + make_function_rtl (current_function_decl); + + restype = TREE_TYPE (TREE_TYPE (current_function_decl)); + DECL_RESULT (current_function_decl) + = build_decl (RESULT_DECL, NULL_TREE, restype); + + if (!nested) + /* Allocate further tree nodes temporarily during compilation of this + function only. */ + temporary_allocation (); + + if (!nested) + TREE_ADDRESSABLE (current_function_decl) = 1; + + immediate_size_expand = old_immediate_size_expand; +} + +/* Here are the public functions the GNU back end needs. */ + +/* This is used by the `assert' macro. It is provided in libgcc.a, + which `cc' doesn't know how to link. Note that the C++ front-end + no longer actually uses the `assert' macro (instead, it calls + my_friendly_assert). But all of the back-end files still need this. */ +void +__eprintf (string, expression, line, filename) +#ifdef __STDC__ + const char *string; + const char *expression; + unsigned line; + const char *filename; +#else + char *string; + char *expression; + unsigned line; + char *filename; +#endif +{ + fprintf (stderr, string, expression, line, filename); + fflush (stderr); + abort (); +} + +tree +convert (type, expr) + tree type, expr; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + if (code == VOID_TYPE) + return build1 (CONVERT_EXPR, type, e); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))), + e); + if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) + return fold (convert_to_integer (type, e)); + if (code == POINTER_TYPE) + return fold (convert_to_pointer (type, e)); + if (code == REAL_TYPE) + return fold (convert_to_real (type, e)); + if (code == COMPLEX_TYPE) + return fold (convert_to_complex (type, e)); + if (code == RECORD_TYPE) + return fold (ffecom_convert_to_complex_ (type, e)); + + assert ("conversion to non-scalar type requested" == NULL); + return error_mark_node; +} + +/* integrate_decl_tree calls this function, but since we don't use the + DECL_LANG_SPECIFIC field, this is a no-op. */ + +void +copy_lang_decl (node) + tree node UNUSED; +{ +} + +/* Return the list of declarations of the current level. + Note that this list is in reverse order unless/until + you nreverse it; and when you do nreverse it, you must + store the result back using `storedecls' or you will lose. */ + +tree +getdecls () +{ + return current_binding_level->names; +} + +/* Nonzero if we are currently in the global binding level. */ + +int +global_bindings_p () +{ + return current_binding_level == global_binding_level; +} + +/* Insert BLOCK at the end of the list of subblocks of the + current binding level. This is used when a BIND_EXPR is expanded, + to handle the BLOCK node inside the BIND_EXPR. */ + +void +incomplete_type_error (value, type) + tree value UNUSED; + tree type; +{ + if (TREE_CODE (type) == ERROR_MARK) + return; + + assert ("incomplete type?!?" == NULL); +} + +void +init_decl_processing () +{ + malloc_init (); + ffe_init_0 (); +} + +void +init_lex () +{ +#if BUILT_FOR_270 + extern void (*print_error_function) (char *); +#endif + + /* Make identifier nodes long enough for the language-specific slots. */ + set_identifier_size (sizeof (struct lang_identifier)); + decl_printable_name = lang_printable_name; +#if BUILT_FOR_270 + print_error_function = lang_print_error_function; +#endif +} + +void +insert_block (block) + tree block; +{ + TREE_USED (block) = 1; + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); +} + +int +lang_decode_option (p) + char *p; +{ + return ffe_decode_option (p); +} + +void +lang_finish () +{ + ffe_terminate_0 (); + + if (ffe_is_ffedebug ()) + malloc_pool_display (malloc_pool_image ()); +} + +char * +lang_identify () +{ + return "f77"; +} + +void +lang_init () +{ + extern FILE *finput; /* Don't pollute com.h with this. */ + + /* If the file is output from cpp, it should contain a first line + `# 1 "real-filename"', and the current design of gcc (toplev.c + in particular and the way it sets up information relied on by + INCLUDE) requires that we read this now, and store the + "real-filename" info in master_input_filename. Ask the lexer + to try doing this. */ + ffelex_hash_kludge (finput); +} + +int +mark_addressable (exp) + tree exp; +{ + register tree x = exp; + while (1) + switch (TREE_CODE (x)) + { + case ADDR_EXPR: + case COMPONENT_REF: + case ARRAY_REF: + x = TREE_OPERAND (x, 0); + break; + + case CONSTRUCTOR: + TREE_ADDRESSABLE (x) = 1; + return 1; + + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) + && DECL_NONLOCAL (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register variable requested" == NULL); + } + else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register var requested" == NULL); + } + put_var_into_stack (x); + + /* drops in */ + case FUNCTION_DECL: + TREE_ADDRESSABLE (x) = 1; +#if 0 /* poplevel deals with this now. */ + if (DECL_CONTEXT (x) == 0) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; +#endif + + default: + return 1; + } +} + +/* If DECL has a cleanup, build and return that cleanup here. + This is a callback called by expand_expr. */ + +tree +maybe_build_cleanup (decl) + tree decl UNUSED; +{ + /* There are no cleanups in Fortran. */ + return NULL_TREE; +} + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. + + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ + +tree +poplevel (keep, reverse, functionbody) + int keep; + int reverse; + int functionbody; +{ + register tree link; + /* The chain of decls was accumulated in reverse order. Put it into forward + order, just for cleanliness. */ + tree decls; + tree subblocks = current_binding_level->blocks; + tree block = 0; + tree decl; + int block_previously_created; + + /* Get the decls in the order they were written. Usually + current_binding_level->names is in reverse order. But parameter decls + were previously put in forward order. */ + + if (reverse) + current_binding_level->names + = decls = nreverse (current_binding_level->names); + else + decls = current_binding_level->names; + + /* Output any nested inline functions within this block if they weren't + already output. */ + + for (decl = decls; decl; decl = TREE_CHAIN (decl)) + if (TREE_CODE (decl) == FUNCTION_DECL + && !TREE_ASM_WRITTEN (decl) + && DECL_INITIAL (decl) != 0 + && TREE_ADDRESSABLE (decl)) + { + /* If this decl was copied from a file-scope decl on account of a + block-scope extern decl, propagate TREE_ADDRESSABLE to the + file-scope decl. */ + if (DECL_ABSTRACT_ORIGIN (decl) != 0) + TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; + else + { + push_function_context (); + output_inline_function (decl); + pop_function_context (); + } + } + + /* If there were any declarations or structure tags in that level, or if + this level is a function body, create a BLOCK to record them for the + life of this function. */ + + block = 0; + block_previously_created = (current_binding_level->this_block != 0); + if (block_previously_created) + block = current_binding_level->this_block; + else if (keep || functionbody) + block = make_node (BLOCK); + if (block != 0) + { + BLOCK_VARS (block) = decls; + BLOCK_SUBBLOCKS (block) = subblocks; + remember_end_note (block); + } + + /* In each subblock, record that this is its superior. */ + + for (link = subblocks; link; link = TREE_CHAIN (link)) + BLOCK_SUPERCONTEXT (link) = block; + + /* Clear out the meanings of the local variables of this level. */ + + for (link = decls; link; link = TREE_CHAIN (link)) + { + if (DECL_NAME (link) != 0) + { + /* If the ident. was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (link)) + { + if (TREE_USED (link)) + TREE_USED (DECL_NAME (link)) = 1; + if (TREE_ADDRESSABLE (link)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1; + } + IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0; + } + } + + /* If the level being exited is the top level of a function, check over all + the labels, and clear out the current (function local) meanings of their + names. */ + + if (functionbody) + { + /* If this is the top level block of a function, the vars are the + function's parameters. Don't leave them in the BLOCK because they + are found in the FUNCTION_DECL instead. */ + + BLOCK_VARS (block) = 0; + } + + /* Pop the current level, and free the structure for reuse. */ + + { + register struct binding_level *level = current_binding_level; + current_binding_level = current_binding_level->level_chain; + + level->level_chain = free_binding_level; + free_binding_level = level; + } + + /* Dispose of the block that we just made inside some higher level. */ + if (functionbody) + DECL_INITIAL (current_function_decl) = block; + else if (block) + { + if (!block_previously_created) + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); + } + /* If we did not make a block for the level just exited, any blocks made + for inner levels (since they cannot be recorded as subblocks in that + level) must be carried forward so they will later become subblocks of + something else. */ + else if (subblocks) + current_binding_level->blocks + = chainon (current_binding_level->blocks, subblocks); + + /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this + binding contour so that they point to the appropriate construct, i.e. + either to the current FUNCTION_DECL node, or else to the BLOCK node we + just constructed. + + Note that for tagged types whose scope is just the formal parameter list + for some function type specification, we can't properly set their + TYPE_CONTEXTs here, because we don't have a pointer to the appropriate + FUNCTION_TYPE node readily available to us. For those cases, the + TYPE_CONTEXTs of the relevant tagged type nodes get set in + `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which + will represent the "scope" for these "parameter list local" tagged + types. */ + + if (block) + TREE_USED (block) = 1; + return block; +} + +void +print_lang_decl (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; +{ +} + +void +print_lang_identifier (file, node, indent) + FILE *file; + tree node; + int indent; +{ + print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4); + print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); +} + +void +print_lang_statistics () +{ +} + +void +print_lang_type (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; +{ +} + +/* Record a decl-node X as belonging to the current lexical scope. + Check for errors (such as an incompatible declaration for the same + name already seen in the same scope). + + Returns either X or an old decl for the same name. + If an old decl is returned, it may have been smashed + to agree with what X says. */ + +tree +pushdecl (x) + tree x; +{ + register tree t; + register tree name = DECL_NAME (x); + register struct binding_level *b = current_binding_level; + + if ((TREE_CODE (x) == FUNCTION_DECL) + && (DECL_INITIAL (x) == 0) + && DECL_EXTERNAL (x)) + DECL_CONTEXT (x) = NULL_TREE; + else + DECL_CONTEXT (x) = current_function_decl; + + if (name) + { + if (IDENTIFIER_INVENTED (name)) + { +#if BUILT_FOR_270 + DECL_ARTIFICIAL (x) = 1; +#endif + DECL_IN_SYSTEM_HEADER (x) = 1; + DECL_IGNORED_P (x) = 1; + TREE_USED (x) = 1; + if (TREE_CODE (x) == TYPE_DECL) + TYPE_DECL_SUPPRESS_DEBUG (x) = 1; + } + + t = lookup_name_current_level (name); + + assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE)); + + /* Don't push non-parms onto list for parms until we understand + why we're doing this and whether it works. */ + + assert ((b == global_binding_level) + || !ffecom_transform_only_dummies_ + || TREE_CODE (x) == PARM_DECL); + + if ((t != NULL_TREE) && duplicate_decls (x, t)) + return t; + + /* If we are processing a typedef statement, generate a whole new + ..._TYPE node (which will be just an variant of the existing + ..._TYPE node with identical properties) and then install the + TYPE_DECL node generated to represent the typedef name as the + TYPE_NAME of this brand new (duplicate) ..._TYPE node. + + The whole point here is to end up with a situation where each and every + ..._TYPE node the compiler creates will be uniquely associated with + AT MOST one node representing a typedef name. This way, even though + the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL + (i.e. "typedef name") nodes very early on, later parts of the + compiler can always do the reverse translation and get back the + corresponding typedef name. For example, given: + + typedef struct S MY_TYPE; MY_TYPE object; + + Later parts of the compiler might only know that `object' was of type + `struct S' if if were not for code just below. With this code + however, later parts of the compiler see something like: + + struct S' == struct S typedef struct S' MY_TYPE; struct S' object; + + And they can then deduce (from the node for type struct S') that the + original object declaration was: + + MY_TYPE object; + + Being able to do this is important for proper support of protoize, and + also for generating precise symbolic debugging information which + takes full account of the programmer's (typedef) vocabulary. + + Obviously, we don't want to generate a duplicate ..._TYPE node if the + TYPE_DECL node that we are now processing really represents a + standard built-in type. + + Since all standard types are effectively declared at line zero in the + source file, we can easily check to see if we are working on a + standard type by checking the current value of lineno. */ + + if (TREE_CODE (x) == TYPE_DECL) + { + if (DECL_SOURCE_LINE (x) == 0) + { + if (TYPE_NAME (TREE_TYPE (x)) == 0) + TYPE_NAME (TREE_TYPE (x)) = x; + } + else if (TREE_TYPE (x) != error_mark_node) + { + tree tt = TREE_TYPE (x); + + tt = build_type_copy (tt); + TYPE_NAME (tt) = x; + TREE_TYPE (x) = tt; + } + } + + /* This name is new in its binding level. Install the new declaration + and return it. */ + if (b == global_binding_level) + IDENTIFIER_GLOBAL_VALUE (name) = x; + else + IDENTIFIER_LOCAL_VALUE (name) = x; + } + + /* Put decls on list in reverse order. We will reverse them later if + necessary. */ + TREE_CHAIN (x) = b->names; + b->names = x; + + return x; +} + +/* Enter a new binding level. + If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, + not for that of tags. */ + +void +pushlevel (tag_transparent) + int tag_transparent; +{ + register struct binding_level *newlevel = NULL_BINDING_LEVEL; + + assert (!tag_transparent); + + /* Reuse or create a struct for this binding level. */ + + if (free_binding_level) + { + newlevel = free_binding_level; + free_binding_level = free_binding_level->level_chain; + } + else + { + newlevel = make_binding_level (); + } + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + + *newlevel = clear_binding_level; + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; +} + +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ + +void +set_block (block) + register tree block; +{ + current_binding_level->this_block = block; +} + +/* ~~tree.h SHOULD declare this, because toplev.c references it. */ + +/* Can't 'yydebug' a front end not generated by yacc/bison! */ + +void +set_yydebug (value) + int value; +{ + if (value) + fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n"); +} + +tree +signed_or_unsigned_type (unsignedp, type) + int unsignedp; + tree type; +{ + tree type2; + + if (! INTEGRAL_TYPE_P (type)) + return type; + if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + type2 = type_for_size (TYPE_PRECISION (type), unsignedp); + if (type2 == NULL_TREE) + return type; + + return type2; +} + +tree +signed_type (type) + tree type; +{ + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; + + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; +#endif + + type2 = type_for_size (TYPE_PRECISION (type1), 0); + if (type2 != NULL_TREE) + return type2; + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + } + + return type; +} + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or validate its data type for an `if' or `while' statement or ?..: exp. + + This preparation consists of taking the ordinary + representation of an expression expr and producing a valid tree + boolean expression describing whether expr is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be `integer_type_node'. */ + +tree +truthvalue_conversion (expr) + tree expr; +{ + if (TREE_CODE (expr) == ERROR_MARK) + return expr; + +#if 0 /* This appears to be wrong for C++. */ + /* These really should return error_mark_node after 2.4 is stable. + But not all callers handle ERROR_MARK properly. */ + switch (TREE_CODE (TREE_TYPE (expr))) + { + case RECORD_TYPE: + error ("struct type value used where scalar is required"); + return integer_zero_node; + + case UNION_TYPE: + error ("union type value used where scalar is required"); + return integer_zero_node; + + case ARRAY_TYPE: + error ("array type value used where scalar is required"); + return integer_zero_node; + + default: + break; + } +#endif /* 0 */ + + switch (TREE_CODE (expr)) + { + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + case COMPONENT_REF: + /* A one-bit unsigned bit-field is already acceptable. */ + if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) + && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) + return expr; + break; +#endif + + case EQ_EXPR: + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + if (integer_zerop (TREE_OPERAND (expr, 1))) + return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0); +#endif + case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + TREE_TYPE (expr) = integer_type_node; + return expr; + + case ERROR_MARK: + return expr; + + case INTEGER_CST: + return integer_zerop (expr) ? integer_zero_node : integer_one_node; + + case REAL_CST: + return real_zerop (expr) ? integer_zero_node : integer_one_node; + + case ADDR_EXPR: + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) + return build (COMPOUND_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), integer_one_node); + else + return integer_one_node; + + case COMPLEX_EXPR: + return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (TREE_OPERAND (expr, 0)), + truthvalue_conversion (TREE_OPERAND (expr, 1))); + + case NEGATE_EXPR: + case ABS_EXPR: + case FLOAT_EXPR: + case FFS_EXPR: + /* These don't change whether an object is non-zero or zero. */ + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + + case LROTATE_EXPR: + case RROTATE_EXPR: + /* These don't change whether an object is zero or non-zero, but + we can't ignore them if their second arg has side-effects. */ + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) + return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1), + truthvalue_conversion (TREE_OPERAND (expr, 0))); + else + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + + case COND_EXPR: + /* Distribute the conversion into the arms of a COND_EXPR. */ + return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0), + truthvalue_conversion (TREE_OPERAND (expr, 1)), + truthvalue_conversion (TREE_OPERAND (expr, 2)))); + + case CONVERT_EXPR: + /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, + since that affects how `default_conversion' will behave. */ + if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE + || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) + break; + /* fall through... */ + case NOP_EXPR: + /* If this is widening the argument, we can ignore it. */ + if (TYPE_PRECISION (TREE_TYPE (expr)) + >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + break; + + case MINUS_EXPR: + /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize + this case. */ + if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT + && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE) + break; + /* fall through... */ + case BIT_XOR_EXPR: + /* This and MINUS_EXPR can be changed into a comparison of the + two objects. */ + if (TREE_TYPE (TREE_OPERAND (expr, 0)) + == TREE_TYPE (TREE_OPERAND (expr, 1))) + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + TREE_OPERAND (expr, 1)); + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + fold (build1 (NOP_EXPR, + TREE_TYPE (TREE_OPERAND (expr, 0)), + TREE_OPERAND (expr, 1)))); + + case BIT_AND_EXPR: + if (integer_onep (TREE_OPERAND (expr, 1))) + return expr; + break; + + case MODIFY_EXPR: +#if 0 /* No such thing in Fortran. */ + if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR) + warning ("suggest parentheses around assignment used as truth value"); +#endif + break; + + default: + break; + } + + if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) + return (ffecom_2 + ((TREE_SIDE_EFFECTS (expr) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (ffecom_1 (REALPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)), + truthvalue_conversion (ffecom_1 (IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)))); + + return ffecom_2 (NE_EXPR, integer_type_node, + expr, + convert (TREE_TYPE (expr), integer_zero_node)); +} + +tree +type_for_mode (mode, unsignedp) + enum machine_mode mode; + int unsignedp; +{ + int i; + int j; + tree t; + + if (mode == TYPE_MODE (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (mode == TYPE_MODE (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (mode == TYPE_MODE (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (mode == TYPE_MODE (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (mode == TYPE_MODE (long_long_integer_type_node)) + return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; + + if (mode == TYPE_MODE (float_type_node)) + return float_type_node; + + if (mode == TYPE_MODE (double_type_node)) + return double_type_node; + + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return build_pointer_type (char_type_node); + + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return build_pointer_type (integer_type_node); + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if (((t = ffecom_tree_type[i][j]) != NULL_TREE) + && (mode == TYPE_MODE (t))) + if ((i == FFEINFO_basictypeINTEGER) && unsignedp) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j]; + else + return t; + } + + return 0; +} + +tree +type_for_size (bits, unsignedp) + unsigned bits; + int unsignedp; +{ + ffeinfoKindtype kt; + tree type_node; + + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + + if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node))) + return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt] + : type_node; + } + + return 0; +} + +tree +unsigned_type (type) + tree type; +{ + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; + + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; +#endif + + type2 = type_for_size (TYPE_PRECISION (type1), 1); + if (type2 != NULL_TREE) + return type2; + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + } + + return type; +} + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#if FFECOM_GCC_INCLUDE + +/* From gcc/cccp.c, the code to handle -I. */ + +/* Skip leading "./" from a directory name. + This may yield the empty string, which represents the current directory. */ + +static char * +skip_redundant_dir_prefix (char *dir) +{ + while (dir[0] == '.' && dir[1] == '/') + for (dir += 2; *dir == '/'; dir++) + continue; + if (dir[0] == '.' && !dir[1]) + dir++; + return dir; +} + +/* The file_name_map structure holds a mapping of file names for a + particular directory. This mapping is read from the file named + FILE_NAME_MAP_FILE in that directory. Such a file can be used to + map filenames on a file system with severe filename restrictions, + such as DOS. The format of the file name map file is just a series + of lines with two tokens on each line. The first token is the name + to map, and the second token is the actual name to use. */ + +struct file_name_map +{ + struct file_name_map *map_next; + char *map_from; + char *map_to; +}; + +#define FILE_NAME_MAP_FILE "header.gcc" + +/* Current maximum length of directory names in the search path + for include files. (Altered as we get more of them.) */ + +static int max_include_len = 0; + +struct file_name_list + { + struct file_name_list *next; + char *fname; + /* Mapping of file names for this directory. */ + struct file_name_map *name_map; + /* Non-zero if name_map is valid. */ + int got_name_map; + }; + +static struct file_name_list *include = NULL; /* First dir to search */ +static struct file_name_list *last_include = NULL; /* Last in chain */ + +/* I/O buffer structure. + The `fname' field is nonzero for source files and #include files + and for the dummy text used for -D and -U. + It is zero for rescanning results of macro expansion + and for expanding macro arguments. */ +#define INPUT_STACK_MAX 400 +static struct file_buf { + char *fname; + /* Filename specified with #line command. */ + char *nominal_fname; + /* Record where in the search path this file was found. + For #include_next. */ + struct file_name_list *dir; + ffewhereLine line; + ffewhereColumn column; +} instack[INPUT_STACK_MAX]; + +static int last_error_tick = 0; /* Incremented each time we print it. */ +static int input_file_stack_tick = 0; /* Incremented when status changes. */ + +/* Current nesting level of input sources. + `instack[indepth]' is the level currently being read. */ +static int indepth = -1; + +typedef struct file_buf FILE_BUF; + +typedef unsigned char U_CHAR; + +/* table to tell if char can be part of a C identifier. */ +U_CHAR is_idchar[256]; +/* table to tell if char can be first char of a c identifier. */ +U_CHAR is_idstart[256]; +/* table to tell if c is horizontal space. */ +U_CHAR is_hor_space[256]; +/* table to tell if c is horizontal or vertical space. */ +static U_CHAR is_space[256]; + +#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0) +#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0) + +/* Nonzero means -I- has been seen, + so don't look for #include "foo" the source-file directory. */ +static int ignore_srcdir; + +#ifndef INCLUDE_LEN_FUDGE +#define INCLUDE_LEN_FUDGE 0 +#endif + +static void append_include_chain (struct file_name_list *first, + struct file_name_list *last); +static FILE *open_include_file (char *filename, + struct file_name_list *searchptr); +static void print_containing_files (ffebadSeverity sev); +static char *skip_redundant_dir_prefix (char *); +static char *read_filename_string (int ch, FILE *f); +static struct file_name_map *read_name_map (char *dirname); +static char *savestring (char *input); + +/* Append a chain of `struct file_name_list's + to the end of the main include chain. + FIRST is the beginning of the chain to append, and LAST is the end. */ + +static void +append_include_chain (first, last) + struct file_name_list *first, *last; +{ + struct file_name_list *dir; + + if (!first || !last) + return; + + if (include == 0) + include = first; + else + last_include->next = first; + + for (dir = first; ; dir = dir->next) { + int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE; + if (len > max_include_len) + max_include_len = len; + if (dir == last) + break; + } + + last->next = NULL; + last_include = last; +} + +/* Try to open include file FILENAME. SEARCHPTR is the directory + being tried from the include file search path. This function maps + filenames on file systems based on information read by + read_name_map. */ + +static FILE * +open_include_file (filename, searchptr) + char *filename; + struct file_name_list *searchptr; +{ + register struct file_name_map *map; + register char *from; + char *p, *dir; + + if (searchptr && ! searchptr->got_name_map) + { + searchptr->name_map = read_name_map (searchptr->fname + ? searchptr->fname : "."); + searchptr->got_name_map = 1; + } + + /* First check the mapping for the directory we are using. */ + if (searchptr && searchptr->name_map) + { + from = filename; + if (searchptr->fname) + from += strlen (searchptr->fname) + 1; + for (map = searchptr->name_map; map; map = map->map_next) + { + if (! strcmp (map->map_from, from)) + { + /* Found a match. */ + return fopen (map->map_to, "r"); + } + } + } + + /* Try to find a mapping file for the particular directory we are + looking in. Thus #include <sys/types.h> will look up sys/types.h + in /usr/include/header.gcc and look up types.h in + /usr/include/sys/header.gcc. */ + p = rindex (filename, '/'); +#ifdef DIR_SEPARATOR + if (! p) p = rindex (filename, DIR_SEPARATOR); + else { + char *tmp = rindex (filename, DIR_SEPARATOR); + if (tmp != NULL && tmp > p) p = tmp; + } +#endif + if (! p) + p = filename; + if (searchptr + && searchptr->fname + && strlen (searchptr->fname) == (size_t) (p - filename) + && ! strncmp (searchptr->fname, filename, (int) (p - filename))) + { + /* FILENAME is in SEARCHPTR, which we've already checked. */ + return fopen (filename, "r"); + } + + if (p == filename) + { + from = filename; + map = read_name_map ("."); + } + else + { + dir = (char *) xmalloc (p - filename + 1); + bcopy (filename, dir, p - filename); + dir[p - filename] = '\0'; + from = p + 1; + map = read_name_map (dir); + free (dir); + } + for (; map; map = map->map_next) + if (! strcmp (map->map_from, from)) + return fopen (map->map_to, "r"); + + return fopen (filename, "r"); +} + +/* Print the file names and line numbers of the #include + commands which led to the current file. */ + +static void +print_containing_files (ffebadSeverity sev) +{ + FILE_BUF *ip = NULL; + int i; + int first = 1; + char *str1; + char *str2; + + /* If stack of files hasn't changed since we last printed + this info, don't repeat it. */ + if (last_error_tick == input_file_stack_tick) + return; + + for (i = indepth; i >= 0; i--) + if (instack[i].fname != NULL) { + ip = &instack[i]; + break; + } + + /* Give up if we don't find a source file. */ + if (ip == NULL) + return; + + /* Find the other, outer source files. */ + for (i--; i >= 0; i--) + if (instack[i].fname != NULL) + { + ip = &instack[i]; + if (first) + { + first = 0; + str1 = "In file included"; + } + else + { + str1 = "... ..."; + } + + if (i == 1) + str2 = ":"; + else + str2 = ""; + + ffebad_start_msg ("%A from %B at %0%C", sev); + ffebad_here (0, ip->line, ip->column); + ffebad_string (str1); + ffebad_string (ip->nominal_fname); + ffebad_string (str2); + ffebad_finish (); + } + + /* Record we have printed the status as of this time. */ + last_error_tick = input_file_stack_tick; +} + +/* Read a space delimited string of unlimited length from a stdio + file. */ + +static char * +read_filename_string (ch, f) + int ch; + FILE *f; +{ + char *alloc, *set; + int len; + + len = 20; + set = alloc = xmalloc (len + 1); + if (! is_space[ch]) + { + *set++ = ch; + while ((ch = getc (f)) != EOF && ! is_space[ch]) + { + if (set - alloc == len) + { + len *= 2; + alloc = xrealloc (alloc, len + 1); + set = alloc + len / 2; + } + *set++ = ch; + } + } + *set = '\0'; + ungetc (ch, f); + return alloc; +} + +/* Read the file name map file for DIRNAME. */ + +static struct file_name_map * +read_name_map (dirname) + char *dirname; +{ + /* This structure holds a linked list of file name maps, one per + directory. */ + struct file_name_map_list + { + struct file_name_map_list *map_list_next; + char *map_list_name; + struct file_name_map *map_list_map; + }; + static struct file_name_map_list *map_list; + register struct file_name_map_list *map_list_ptr; + char *name; + FILE *f; + size_t dirlen; + int separator_needed; + + dirname = skip_redundant_dir_prefix (dirname); + + for (map_list_ptr = map_list; map_list_ptr; + map_list_ptr = map_list_ptr->map_list_next) + if (! strcmp (map_list_ptr->map_list_name, dirname)) + return map_list_ptr->map_list_map; + + map_list_ptr = ((struct file_name_map_list *) + xmalloc (sizeof (struct file_name_map_list))); + map_list_ptr->map_list_name = savestring (dirname); + map_list_ptr->map_list_map = NULL; + + dirlen = strlen (dirname); + separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; + name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2); + strcpy (name, dirname); + name[dirlen] = '/'; + strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE); + f = fopen (name, "r"); + free (name); + if (!f) + map_list_ptr->map_list_map = NULL; + else + { + int ch; + + while ((ch = getc (f)) != EOF) + { + char *from, *to; + struct file_name_map *ptr; + + if (is_space[ch]) + continue; + from = read_filename_string (ch, f); + while ((ch = getc (f)) != EOF && is_hor_space[ch]) + ; + to = read_filename_string (ch, f); + + ptr = ((struct file_name_map *) + xmalloc (sizeof (struct file_name_map))); + ptr->map_from = from; + + /* Make the real filename absolute. */ + if (*to == '/') + ptr->map_to = to; + else + { + ptr->map_to = xmalloc (dirlen + strlen (to) + 2); + strcpy (ptr->map_to, dirname); + ptr->map_to[dirlen] = '/'; + strcpy (ptr->map_to + dirlen + separator_needed, to); + free (to); + } + + ptr->map_next = map_list_ptr->map_list_map; + map_list_ptr->map_list_map = ptr; + + while ((ch = getc (f)) != '\n') + if (ch == EOF) + break; + } + fclose (f); + } + + map_list_ptr->map_list_next = map_list; + map_list = map_list_ptr; + + return map_list_ptr->map_list_map; +} + +static char * +savestring (input) + char *input; +{ + unsigned size = strlen (input); + char *output = xmalloc (size + 1); + strcpy (output, input); + return output; +} + +static void +ffecom_file_ (char *name) +{ + FILE_BUF *fp; + + /* Do partial setup of input buffer for the sake of generating + early #line directives (when -g is in effect). */ + + fp = &instack[++indepth]; + bzero ((char *) fp, sizeof (FILE_BUF)); + if (name == NULL) + name = ""; + fp->nominal_fname = fp->fname = name; +} + +/* Initialize syntactic classifications of characters. */ + +static void +ffecom_initialize_char_syntax_ () +{ + register int i; + + /* + * Set up is_idchar and is_idstart tables. These should be + * faster than saying (is_alpha (c) || c == '_'), etc. + * Set up these things before calling any routines tthat + * refer to them. + */ + for (i = 'a'; i <= 'z'; i++) { + is_idchar[i - 'a' + 'A'] = 1; + is_idchar[i] = 1; + is_idstart[i - 'a' + 'A'] = 1; + is_idstart[i] = 1; + } + for (i = '0'; i <= '9'; i++) + is_idchar[i] = 1; + is_idchar['_'] = 1; + is_idstart['_'] = 1; + + /* horizontal space table */ + is_hor_space[' '] = 1; + is_hor_space['\t'] = 1; + is_hor_space['\v'] = 1; + is_hor_space['\f'] = 1; + is_hor_space['\r'] = 1; + + is_space[' '] = 1; + is_space['\t'] = 1; + is_space['\v'] = 1; + is_space['\f'] = 1; + is_space['\n'] = 1; + is_space['\r'] = 1; +} + +static void +ffecom_close_include_ (FILE *f) +{ + fclose (f); + + indepth--; + input_file_stack_tick++; + + ffewhere_line_kill (instack[indepth].line); + ffewhere_column_kill (instack[indepth].column); +} + +static int +ffecom_decode_include_option_ (char *spec) +{ + struct file_name_list *dirtmp; + + if (! ignore_srcdir && !strcmp (spec, "-")) + ignore_srcdir = 1; + else + { + dirtmp = (struct file_name_list *) + xmalloc (sizeof (struct file_name_list)); + dirtmp->next = 0; /* New one goes on the end */ + if (spec[0] != 0) + dirtmp->fname = spec; + else + fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'"); + dirtmp->got_name_map = 0; + append_include_chain (dirtmp, dirtmp); + } + return 1; +} + +/* Open INCLUDEd file. */ + +static FILE * +ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) +{ + char *fbeg = name; + size_t flen = strlen (fbeg); + struct file_name_list *search_start = include; /* Chain of dirs to search */ + struct file_name_list dsp[1]; /* First in chain, if #include "..." */ + struct file_name_list *searchptr = 0; + char *fname; /* Dynamically allocated fname buffer */ + FILE *f; + FILE_BUF *fp; + + if (flen == 0) + return NULL; + + dsp[0].fname = NULL; + + /* If -I- was specified, don't search current dir, only spec'd ones. */ + if (!ignore_srcdir) + { + for (fp = &instack[indepth]; fp >= instack; fp--) + { + int n; + char *ep; + char *nam; + + if ((nam = fp->nominal_fname) != NULL) + { + /* Found a named file. Figure out dir of the file, + and put it in front of the search list. */ + dsp[0].next = search_start; + search_start = dsp; +#ifndef VMS + ep = rindex (nam, '/'); +#ifdef DIR_SEPARATOR + if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR); + else { + char *tmp = rindex (nam, DIR_SEPARATOR); + if (tmp != NULL && tmp > ep) ep = tmp; + } +#endif +#else /* VMS */ + ep = rindex (nam, ']'); + if (ep == NULL) ep = rindex (nam, '>'); + if (ep == NULL) ep = rindex (nam, ':'); + if (ep != NULL) ep++; +#endif /* VMS */ + if (ep != NULL) + { + n = ep - nam; + dsp[0].fname = (char *) xmalloc (n + 1); + strncpy (dsp[0].fname, nam, n); + dsp[0].fname[n] = '\0'; + if (n + INCLUDE_LEN_FUDGE > max_include_len) + max_include_len = n + INCLUDE_LEN_FUDGE; + } + else + dsp[0].fname = NULL; /* Current directory */ + dsp[0].got_name_map = 0; + break; + } + } + } + + /* Allocate this permanently, because it gets stored in the definitions + of macros. */ + fname = xmalloc (max_include_len + flen + 4); + /* + 2 above for slash and terminating null. */ + /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED + for g77 yet). */ + + /* If specified file name is absolute, just open it. */ + + if (*fbeg == '/' +#ifdef DIR_SEPARATOR + || *fbeg == DIR_SEPARATOR +#endif + ) + { + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + f = open_include_file (fname, NULL_PTR); + } + else + { + f = NULL; + + /* Search directory path, trying to open the file. + Copy each filename tried into FNAME. */ + + for (searchptr = search_start; searchptr; searchptr = searchptr->next) + { + if (searchptr->fname) + { + /* The empty string in a search path is ignored. + This makes it possible to turn off entirely + a standard piece of the list. */ + if (searchptr->fname[0] == 0) + continue; + strcpy (fname, skip_redundant_dir_prefix (searchptr->fname)); + if (fname[0] && fname[strlen (fname) - 1] != '/') + strcat (fname, "/"); + fname[strlen (fname) + flen] = 0; + } + else + fname[0] = 0; + + strncat (fname, fbeg, flen); +#ifdef VMS + /* Change this 1/2 Unix 1/2 VMS file specification into a + full VMS file specification */ + if (searchptr->fname && (searchptr->fname[0] != 0)) + { + /* Fix up the filename */ + hack_vms_include_specification (fname); + } + else + { + /* This is a normal VMS filespec, so use it unchanged. */ + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; +#if 0 /* Not for g77. */ + /* if it's '#include filename', add the missing .h */ + if (index (fname, '.') == NULL) + strcat (fname, ".h"); +#endif + } +#endif /* VMS */ + f = open_include_file (fname, searchptr); +#ifdef EACCES + if (f == NULL && errno == EACCES) + { + print_containing_files (FFEBAD_severityWARNING); + ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable", + FFEBAD_severityWARNING); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + } +#endif + if (f != NULL) + break; + } + } + + if (f == NULL) + { + /* A file that was not found. */ + + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE)); + ffebad_start (FFEBAD_OPEN_INCLUDE); + ffebad_here (0, l, c); + ffebad_string (fname); + ffebad_finish (); + } + + if (dsp[0].fname != NULL) + free (dsp[0].fname); + + if (f == NULL) + return NULL; + + if (indepth >= (INPUT_STACK_MAX - 1)) + { + print_containing_files (FFEBAD_severityFATAL); + ffebad_start_msg ("At %0, INCLUDE nesting too deep", + FFEBAD_severityFATAL); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + return NULL; + } + + instack[indepth].line = ffewhere_line_use (l); + instack[indepth].column = ffewhere_column_use (c); + + fp = &instack[indepth + 1]; + bzero ((char *) fp, sizeof (FILE_BUF)); + fp->nominal_fname = fp->fname = fname; + fp->dir = searchptr; + + indepth++; + input_file_stack_tick++; + + return f; +} +#endif /* FFECOM_GCC_INCLUDE */ |