diff options
Diffstat (limited to 'contrib/gcc/f/com.c')
| -rw-r--r-- | contrib/gcc/f/com.c | 16525 |
1 files changed, 0 insertions, 16525 deletions
diff --git a/contrib/gcc/f/com.c b/contrib/gcc/f/com.c deleted file mode 100644 index a64ef86..0000000 --- a/contrib/gcc/f/com.c +++ /dev/null @@ -1,16525 +0,0 @@ -/* com.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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): - 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 (); - - Everything Else: - tree d; - tree init; - // 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); - -*/ - -/* Include files. */ - -#include "proj.h" -#include "flags.h" -#include "real.h" -#include "rtl.h" -#include "toplev.h" -#include "tree.h" -#include "output.h" /* Must follow tree.h so TREE_CODE is defined! */ -#include "convert.h" -#include "ggc.h" -#include "diagnostic.h" -#include "intl.h" -#include "langhooks.h" -#include "langhooks-def.h" -#include "debug.h" - -/* 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 */ -#endif /* VMS */ - -#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. */ - -/* Stream for reading from the input file. */ -FILE *finput; - -/* 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). */ - -tree string_type_node; - -/* 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 GTY(()) tree ffecom_tree_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 GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; -static GTY(()) tree - ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; -static GTY(()) tree ffecom_tree_subr_type; -static GTY(()) tree ffecom_tree_ptr_to_subr_type; -static GTY(()) tree ffecom_tree_blockdata_type; - -static GTY(()) tree ffecom_tree_xargc_; - -ffecomSymbol ffecom_symbol_null_ -= -{ - NULL_TREE, - NULL_TREE, - NULL_TREE, - NULL_TREE, - false -}; -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; -static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node; -tree ffecom_f2c_address_type_node; -tree ffecom_f2c_real_type_node; -static GTY(()) 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; - -/* 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_rttypeVOIDSTAR_, /* C's `void *' type. */ - FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */ - FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */ - FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */ - FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */ - FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */ - FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */ - FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */ - FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */ - FFECOM_rttypeDOUBLE_, /* C's `double' type. */ - FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */ - FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */ - FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */ - FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */ - FFECOM_rttype_ - } ffecomRttype_; - -/* Internal typedefs. */ - -typedef struct _ffecom_concat_list_ ffecomConcatList_; - -/* Private include files. */ - - -/* Internal structure definitions. */ - -struct _ffecom_concat_list_ - { - ffebld *exprs; - int count; - int max; - ffetargetCharacterSize minlen; - ffetargetCharacterSize maxlen; - }; - -/* Static functions (internal). */ - -static tree ffe_type_for_mode (enum machine_mode, int); -static tree ffe_type_for_size (unsigned int, int); -static tree ffe_unsigned_type (tree); -static tree ffe_signed_type (tree); -static tree ffe_signed_or_unsigned_type (int, tree); -static bool ffe_mark_addressable (tree); -static tree ffe_truthvalue_conversion (tree); -static void ffecom_init_decl_processing (void); -static tree ffecom_arglist_expr_ (const 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, const 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, tree hook); -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, bool ref, tree hook); -static void ffecom_char_args_x_ (tree *xitem, tree *length, - ffebld expr, bool with_null); -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, const 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, bool widenp); -static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, - ffebld dest, bool *dest_used); -static tree ffecom_expr_power_integer_ (ffebld expr); -static void ffecom_expr_transform_ (ffebld expr); -static void ffecom_f2c_make_type_ (tree *type, int tcode, const 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, const char *text); -static tree ffecom_get_external_identifier_ (ffesymbol s); -static tree ffecom_get_identifier_ (const char *text); -static tree ffecom_gen_sfuncdef_ (ffesymbol s, - ffeinfoBasictype bt, - ffeinfoKindtype kt); -static const 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); -static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); -static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, - ffebld source); -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, tree hook); -static tree ffecom_type_localvar_ (ffesymbol s, - ffeinfoBasictype bt, - ffeinfoKindtype kt); -static tree ffecom_type_namelist_ (void); -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); -static tree ffecom_convert_narrow_ (tree type, tree expr); -static tree ffecom_convert_widen_ (tree type, tree expr); - -/* These are static functions that parallel those found in the C front - end and thus have the same names. */ - -static tree bison_rule_compstmt_ (void); -static void bison_rule_pushlevel_ (void); -static void delete_block (tree block); -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 const char *ffe_printable_name (tree decl, int v); -static void ffe_print_error_function (diagnostic_context *, const char *); -static tree lookup_name_current_level (tree name); -static struct f_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 int kept_level_p (void); -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); -static void ffecom_file_ (const char *name); -static void ffecom_close_include_ (FILE *f); -static FILE *ffecom_open_include_ (char *name, ffewhereLine l, - ffewhereColumn c); - -/* 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_; -static GTY(()) tree ffecom_outer_function_decl_; -static GTY(()) tree ffecom_previous_function_decl_; -static GTY(()) tree ffecom_which_entrypoint_decl_; -static GTY(()) tree ffecom_float_zero_; -static GTY(()) tree ffecom_float_half_; -static GTY(()) tree ffecom_double_zero_; -static GTY(()) tree ffecom_double_half_; -static GTY(()) tree ffecom_func_result_;/* For functions. */ -static GTY(()) 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 GTY(()) tree ffecom_multi_type_node_; -static GTY(()) tree ffecom_multi_retval_; -static GTY(()) 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; -static int ffecom_typesize_pointer_; -static int ffecom_typesize_integer1_; - -/* Holds pointer-to-function expressions. */ - -static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt]; - -/* Holds the external names of the functions. */ - -static const char *const ffecom_gfrt_name_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function returns. */ - -static const bool ffecom_gfrt_volatile_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function returns type complex. */ - -static const bool ffecom_gfrt_complex_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Whether the function is const - (i.e., has no side effects and only depends on its arguments). */ - -static const bool ffecom_gfrt_const_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Type code for the function return value. */ - -static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* String of codes for the function's arguments. */ - -static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt] -= -{ -#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS, -#include "com-rt.def" -#undef DEFGFRT -}; - -/* Internal macros. */ - -/* 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. */ - -#ifndef SIZE_TYPE -#define SIZE_TYPE "long unsigned 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_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE) -#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE) - -/* 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 f_binding_level GTY(()) - { - /* 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 f_binding_level *level_chain; - - /* 0: no ffecom_prepare_* functions called at this level yet; - 1: ffecom_prepare* functions called, except not ffecom_prepare_end; - 2: ffecom_prepare_end called. */ - int prep_state; - }; - -#define NULL_BINDING_LEVEL (struct f_binding_level *) NULL - -/* The binding level currently in effect. */ - -static GTY(()) struct f_binding_level *current_binding_level; - -/* A chain of binding_level structures awaiting reuse. */ - -static GTY((deletable (""))) struct f_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 f_binding_level *global_binding_level; - -/* Binding level structures are initialized by copying this one. */ - -static const struct f_binding_level clear_binding_level -= -{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0}; - -/* Language-dependent contents of an identifier. */ - -struct lang_identifier GTY(()) -{ - struct tree_identifier common; - tree global_value; - tree local_value; - tree 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) - -/* The resulting tree type. */ -union lang_tree_node - GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), - chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) -{ - union tree_node GTY ((tag ("0"), - desc ("tree_node_structure (&%h)"))) - generic; - struct lang_identifier GTY ((tag ("1"))) identifier; -}; - -/* Fortran doesn't use either of these. */ -struct lang_decl GTY(()) -{ -}; -struct lang_type GTY(()) -{ -}; - -/* 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 GTY(()) tree named_labels; - -/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */ - -static GTY(()) tree shadowed_labels; - -/* Return the subscript expression, modified to do range-checking. - - `array' is the array type to be checked against. - `element' is the subscript expression to check. - `dim' is the dimension number (starting at 0). - `total_dims' is the total number of dimensions (0 for CHARACTER substring). - `item' is the array decl or NULL_TREE. -*/ - -static tree -ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, - const char *array_name, tree item) -{ - tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); - tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array)); - tree cond; - tree die; - tree args; - - if (element == error_mark_node) - return element; - - if (TREE_TYPE (low) != TREE_TYPE (element)) - { - if (TYPE_PRECISION (TREE_TYPE (low)) - > TYPE_PRECISION (TREE_TYPE (element))) - element = convert (TREE_TYPE (low), element); - else - { - low = convert (TREE_TYPE (element), low); - if (high) - high = convert (TREE_TYPE (element), high); - } - } - - element = ffecom_save_tree (element); - if (total_dims == 0) - { - /* Special handling for substring range checks. Fortran allows the - end subscript < begin subscript, which means that expressions like - string(1:0) are valid (and yield a null string). In view of this, - enforce two simpler conditions: - 1) element<=high for end-substring; - 2) element>=low for start-substring. - Run-time character movement will enforce remaining conditions. - - More complicated checks would be better, but present structure only - provides one index element at a time, so it is not possible to - enforce a check of both i and j in string(i:j). If it were, the - complete set of rules would read, - if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) || - ((low<=i<=high) && (low<=j<=high)) ) - ok ; - else - range error ; - */ - if (dim) - cond = ffecom_2 (LE_EXPR, integer_type_node, element, high); - else - cond = ffecom_2 (LE_EXPR, integer_type_node, low, element); - } - else - { - /* Array reference substring range checking. */ - - cond = ffecom_2 (LE_EXPR, integer_type_node, - low, - element); - if (high) - { - cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, - cond, - ffecom_2 (LE_EXPR, integer_type_node, - element, - high)); - } - } - - /* If the array index is safe at compile-time, return element. */ - if (integer_nonzerop (cond)) - return element; - - { - int len; - char *proc; - char *var; - tree arg3; - tree arg2; - tree arg1; - tree arg4; - - switch (total_dims) - { - case 0: - var = concat (array_name, "[", (dim ? "end" : "start"), - "-substring]", NULL); - len = strlen (var) + 1; - arg1 = build_string (len, var); - free (var); - break; - - case 1: - len = strlen (array_name) + 1; - arg1 = build_string (len, array_name); - break; - - default: - var = xmalloc (strlen (array_name) + 40); - sprintf (var, "%s[subscript-%d-of-%d]", - array_name, - dim + 1, total_dims); - len = strlen (var) + 1; - arg1 = build_string (len, var); - free (var); - break; - } - - TREE_TYPE (arg1) - = build_type_variant (build_array_type (char_type_node, - build_range_type - (integer_type_node, - integer_one_node, - build_int_2 (len, 0))), - 1, 0); - TREE_CONSTANT (arg1) = 1; - TREE_STATIC (arg1) = 1; - arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)), - arg1); - - /* s_rnge adds one to the element to print it, so bias against - that -- want to print a faithful *subscript* value. */ - arg2 = convert (ffecom_f2c_ftnint_type_node, - ffecom_2 (MINUS_EXPR, - TREE_TYPE (element), - element, - convert (TREE_TYPE (element), - integer_one_node))); - - proc = concat (input_filename, "/", - IDENTIFIER_POINTER (DECL_NAME (current_function_decl)), - NULL); - len = strlen (proc) + 1; - arg3 = build_string (len, proc); - - free (proc); - - TREE_TYPE (arg3) - = build_type_variant (build_array_type (char_type_node, - build_range_type - (integer_type_node, - integer_one_node, - build_int_2 (len, 0))), - 1, 0); - TREE_CONSTANT (arg3) = 1; - TREE_STATIC (arg3) = 1; - arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)), - arg3); - - arg4 = convert (ffecom_f2c_ftnint_type_node, - build_int_2 (input_line, 0)); - - arg1 = build_tree_list (NULL_TREE, arg1); - arg2 = build_tree_list (NULL_TREE, arg2); - arg3 = build_tree_list (NULL_TREE, arg3); - arg4 = build_tree_list (NULL_TREE, arg4); - TREE_CHAIN (arg3) = arg4; - TREE_CHAIN (arg2) = arg3; - TREE_CHAIN (arg1) = arg2; - - args = arg1; - } - die = ffecom_call_gfrt (FFECOM_gfrtRANGE, - args, NULL_TREE); - TREE_SIDE_EFFECTS (die) = 1; - die = convert (void_type_node, die); - - if (integer_zerop (cond) && item) - ffe_mark_addressable (item); - - return ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die); -} - -/* Return the computed element of an array reference. - - `item' is NULL_TREE, or the transformed pointer to the array. - `expr' is the original opARRAYREF expression, which is transformed - if `item' is NULL_TREE. - `want_ptr' is nonzero if a pointer to the element, instead of - the element itself, is to be returned. */ - -static tree -ffecom_arrayref_ (tree item, ffebld expr, int want_ptr) -{ - ffebld dims[FFECOM_dimensionsMAX]; - int i; - int total_dims; - int flatten = ffe_is_flatten_arrays (); - int need_ptr; - tree array; - tree element; - tree tree_type; - tree tree_type_x; - const char *array_name; - ffetype type; - ffebld list; - - if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER) - array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr))); - else - array_name = "[expr?]"; - - /* Build up ARRAY_REFs in reverse order (since we're column major - here in Fortran land). */ - - for (i = 0, list = ffebld_right (expr); - list != NULL; - ++i, list = ffebld_trail (list)) - { - dims[i] = ffebld_head (list); - type = ffeinfo_type (ffebld_basictype (dims[i]), - ffebld_kindtype (dims[i])); - if (! flatten - && ffecom_typesize_pointer_ > ffecom_typesize_integer1_ - && ffetype_size (type) > ffecom_typesize_integer1_) - /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit - pointers and 32-bit integers. Do the full 64-bit pointer - arithmetic, for codes using arrays for nonstandard heap-like - work. */ - flatten = 1; - } - - total_dims = i; - - need_ptr = want_ptr || flatten; - - if (! item) - { - if (need_ptr) - item = ffecom_ptr_to_expr (ffebld_left (expr)); - else - item = ffecom_expr (ffebld_left (expr)); - - if (item == error_mark_node) - return item; - - if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING - && ! ffe_mark_addressable (item)) - return error_mark_node; - } - - if (item == error_mark_node) - return item; - - if (need_ptr) - { - tree min; - - for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); - i >= 0; - --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) - { - min = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); - element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); - if (flag_bounds_check) - element = ffecom_subscript_check_ (array, element, i, total_dims, - array_name, item); - if (element == error_mark_node) - return element; - - /* Widen integral arithmetic as desired while preserving - signedness. */ - tree_type = TREE_TYPE (element); - tree_type_x = tree_type; - if (tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - if (TREE_TYPE (min) != tree_type_x) - min = convert (tree_type_x, min); - if (TREE_TYPE (element) != tree_type_x) - element = convert (tree_type_x, element); - - item = ffecom_2 (PLUS_EXPR, - build_pointer_type (TREE_TYPE (array)), - item, - size_binop (MULT_EXPR, - size_in_bytes (TREE_TYPE (array)), - convert (sizetype, - fold (build (MINUS_EXPR, - tree_type_x, - element, min))))); - } - if (! want_ptr) - { - item = ffecom_1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), - item); - } - } - else - { - for (--i; - i >= 0; - --i) - { - array = TYPE_MAIN_VARIANT (TREE_TYPE (item)); - - element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE); - if (flag_bounds_check) - element = ffecom_subscript_check_ (array, element, i, total_dims, - array_name, item); - if (element == error_mark_node) - return element; - - /* Widen integral arithmetic as desired while preserving - signedness. */ - tree_type = TREE_TYPE (element); - tree_type_x = tree_type; - if (tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - element = convert (tree_type_x, element); - - item = ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))), - item, - element); - } - } - - return item; -} - -/* 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. */ - -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: - abort (); - - - 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); - - return result; -} - -/* 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'). */ - -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)); -} - -/* Like gcc's convert(), but crashes if widening might happen. */ - -static tree -ffecom_convert_narrow_ (tree type, tree 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 - && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))) - || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE - && (TYPE_PRECISION (type) - == TREE_INT_CST_LOW (TYPE_SIZE (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); - /* Check that at least the first field name agrees. */ - assert (DECL_NAME (TYPE_FIELDS (type)) - == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); - assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); - if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) - return e; - return fold (ffecom_convert_to_complex_ (type, e)); - } - - assert ("conversion to non-scalar type requested" == NULL); - return error_mark_node; -} - -/* Like gcc's convert(), but crashes if narrowing might happen. */ - -static tree -ffecom_convert_widen_ (tree type, tree 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 - && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))) - || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE - && (TYPE_PRECISION (type) - == TREE_INT_CST_LOW (TYPE_SIZE (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); - /* Check that at least the first field name agrees. */ - assert (DECL_NAME (TYPE_FIELDS (type)) - == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e)))); - assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); - if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) - == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))) - return e; - return fold (ffecom_convert_to_complex_ (type, e)); - } - - assert ("conversion to non-scalar type requested" == NULL); - return error_mark_node; -} - -/* Handles making a COMPLEX type, either the standard - (but buggy?) gbe way, or the safer (but less elegant?) - f2c way. */ - -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; -} - -/* Chooses either the gbe or the f2c way to build a - complex constant. */ - -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, bothparts); - } - else - { - bothparts = build_complex (type, realpart, imagpart); - } - - return bothparts; -} - -static tree -ffecom_arglist_expr_ (const 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; - static const char zed[] = "0"; - - if (c == NULL) - c = &zed[0]; - - 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); - } - } - - /* We've run out of args in the call; if the implementation expects - more, supply null pointers for them, which the implementation can - check to see if an arg was omitted. */ - - while (*c != '\0' && *c != '0') - { - if (*c == '&') - ++c; - else - assert ("missing arg to run-time routine!" == NULL); - - switch (*(c++)) - { - case '\0': - case 'a': - case 'c': - case 'd': - case 'e': - case 'f': - case 'i': - case 'j': - break; - - default: - assert ("bad arg string code" == NULL); - break; - } - *plist - = build_tree_list (NULL_TREE, - null_pointer_node); - plist = &TREE_CHAIN (*plist); - } - - *plist = trail; - - return list; -} - -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; -} - -/* Check whether a partial overlap between two expressions is possible. - - Can *starting* to write a portion of expr1 change the value - computed (perhaps already, *partially*) by expr2? - - Currently, this is a concern only for a COMPLEX expr1. But if it - isn't in COMMON or local EQUIVALENCE, since we don't support - aliasing of arguments, it isn't a concern. */ - -static bool -ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED) -{ - ffesymbol sym; - ffestorag st; - - switch (ffebld_op (expr1)) - { - case FFEBLD_opSYMTER: - sym = ffebld_symter (expr1); - break; - - case FFEBLD_opARRAYREF: - if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER) - return FALSE; - sym = ffebld_symter (ffebld_left (expr1)); - break; - - default: - return FALSE; - } - - if (ffesymbol_where (sym) != FFEINFO_whereCOMMON - && (ffesymbol_where (sym) != FFEINFO_whereLOCAL - || ! (st = ffesymbol_storage (sym)) - || ! ffestorag_parent (st))) - return FALSE; - - /* It's in COMMON or local EQUIVALENCE. */ - - return TRUE; -} - -/* 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. */ - -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 NEGATE_EXPR: - case MIN_EXPR: - case MAX_EXPR: - case ABS_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_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 = bitsize_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. */ -} - -/* 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). */ - -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; -} - -/* 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. */ - -static tree -ffecom_build_f2c_string_ (int i, const char *s) -{ - if (!ffe_is_f2c_library ()) - return build_string (i, s); - - { - char *tmp; - const 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 = 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; - } -} - -/* 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. */ - -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 hook) -{ - 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 = hook; - assert (tempvar); - } - 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; -} - -/* Given two arguments, transform them and make a call to the given - function via ffecom_call_. */ - -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, bool ref, tree hook) -{ - tree left_tree; - tree right_tree; - tree left_length; - tree right_length; - - if (ref) - { - /* Pass arguments by reference. */ - left_tree = ffecom_arg_ptr_to_expr (left, &left_length); - right_tree = ffecom_arg_ptr_to_expr (right, &right_length); - } - else - { - /* Pass arguments by value. */ - left_tree = ffecom_arg_expr (left, &left_length); - right_tree = ffecom_arg_expr (right, &right_length); - } - - - 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, hook); -} - -/* Return ptr/length args for char subexpression - - 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. - - Note that if with_null is TRUE, and the expression is an opCONTER, - a null byte is appended to the string. */ - -static void -ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) -{ - tree item; - tree high; - ffetargetCharacter1 val; - ffetargetCharacterSize newlen; - - switch (ffebld_op (expr)) - { - case FFEBLD_opCONTER: - val = ffebld_constant_character1 (ffebld_conter (expr)); - newlen = ffetarget_length_character1 (val); - if (with_null) - { - /* Begin FFETARGET-NULL-KLUDGE. */ - if (newlen != 0) - ++newlen; - } - *length = build_int_2 (newlen, 0); - TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; - high = build_int_2 (newlen, 0); - TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; - item = build_string (newlen, - ffetarget_text_character1 (val)); - /* End FFETARGET-NULL-KLUDGE. */ - 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: - { - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - if (item == error_mark_node || *length == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - item = ffecom_arrayref_ (item, expr, 1); - } - break; - - case FFEBLD_opSUBSTR: - { - ffebld start; - ffebld end; - ffebld thing = ffebld_right (expr); - tree start_tree; - tree end_tree; - const char *char_name; - ffebld left_symter; - tree array; - - assert (ffebld_op (thing) == FFEBLD_opITEM); - start = ffebld_head (thing); - thing = ffebld_trail (thing); - assert (ffebld_trail (thing) == NULL); - end = ffebld_head (thing); - - /* Determine name for pretty-printing range-check errors. */ - for (left_symter = ffebld_left (expr); - left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF; - left_symter = ffebld_left (left_symter)) - ; - if (ffebld_op (left_symter) == FFEBLD_opSYMTER) - char_name = ffesymbol_text (ffebld_symter (left_symter)); - else - char_name = "[expr?]"; - - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - if (item == error_mark_node || *length == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); - - /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */ - - if (start == NULL) - { - if (end == NULL) - ; - else - { - end_tree = ffecom_expr (end); - if (flag_bounds_check) - end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, - char_name, NULL_TREE); - end_tree = convert (ffecom_f2c_ftnlen_type_node, - end_tree); - - if (end_tree == error_mark_node) - { - item = *length = error_mark_node; - break; - } - - *length = end_tree; - } - } - else - { - start_tree = ffecom_expr (start); - if (flag_bounds_check) - start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0, - char_name, NULL_TREE); - start_tree = convert (ffecom_f2c_ftnlen_type_node, - start_tree); - - 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 = ffecom_expr (end); - if (flag_bounds_check) - end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0, - char_name, NULL_TREE); - end_tree = convert (ffecom_f2c_ftnlen_type_node, - end_tree); - - 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) - /* ~~Kludge alert! This should someday be fixed. */ - size = 24; - - *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); - } - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - tempvar = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (tempvar)), - tempvar); - - 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); - } - break; - - case FFEBLD_opCONVERT: - - ffecom_char_args_ (&item, length, ffebld_left (expr)); - - 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; - - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - 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, NULL_TREE); - 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; -} - -/* 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. */ - -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; - - /* An array is too large if size is negative or the type_size overflows - or its "upper half" is larger than 3 (which would make the signed - byte size and offset computations overflow). */ - - if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0) - || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3 - || 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; -} - -/* 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). */ - -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)); - else - tlen = ffecom_get_invented_identifier ("__g77_%s", "length"); - tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node); - DECL_ARTIFICIAL (tlen) = 1; - } - - if (sz == FFETARGET_charactersizeNONE) - { - assert (tlen != NULL_TREE); - highval = variable_size (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; -} - -/* 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. */ - -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: - /* ~~Do useful truncations here. */ - break; - - 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; - } -} - -/* 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. */ - -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])); -} - -/* Make list of concatenated string exprs. - - Returns a flattened list of concatenated subexpressions given a - tree of such expressions. */ - -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); -} - -/* Provide some kind of useful info on member of aggregate area, - since current g77/gcc technology does not provide debug info - on these members. */ - -static void -ffecom_debug_kludge_ (tree aggr, const 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); -} - -/* 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). */ - -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. */ - location_t old_loc = input_location; - - input_filename = ffesymbol_where_filename (fn); - input_line = ffesymbol_where_filelinenum (fn); - - 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. */ - - 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"); - - /* 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); - - store_parm_decls (0); - - ffecom_start_compstmt (); - /* Disallow temp vars at this level. */ - current_binding_level->prep_state = 2; - - /* Make local var to hold return type for multi-type master fn. */ - - if (multi) - { - multi_retval = ffecom_get_invented_identifier ("__g77_%s", - "multi_retval"); - 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); - } - 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 - || ffesymbol_hook (s).decl_tree == error_mark_node) - 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 - || ffesymbol_hook (s).length_tree == error_mark_node) - 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); - } - } - - ffecom_end_compstmt (); - - finish_function (0); - - input_location = old_loc; - - ffecom_doing_entry_ = FALSE; -} - -/* 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. */ - -static tree -ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used, - bool assignp, bool widenp) -{ - tree item; - tree list; - tree args; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - tree t; - tree dt; /* decl_tree for an ffesymbol. */ - tree tree_type, tree_type_x; - tree left, right; - 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)); - tree_type = ffecom_tree_type[bt][kt]; - - /* Widen integral arithmetic as desired while preserving signedness. */ - tree_type_x = NULL_TREE; - if (widenp && tree_type - && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT - && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype)) - tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype); - - switch (ffebld_op (expr)) - { - case FFEBLD_opACCTER: - { - ffebitCount i; - ffebit bits = ffebld_accter_bits (expr); - ffetargetOffset source_offset = 0; - ffetargetOffset dest_offset = ffebld_accter_pad (expr); - tree purpose; - - assert (dest_offset == 0 - || (bt == FFEINFO_basictypeCHARACTER - && kt == FFEINFO_kindtypeCHARACTER1)); - - 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 - && dest_offset != 0) - purpose = build_int_2 (dest_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; - dest_offset += length; - } - } - - item = build_int_2 ((ffebld_accter_size (expr) - + ffebld_accter_pad (expr)) - 1, 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - return list; - - case FFEBLD_opARRTER: - { - ffetargetOffset i; - - list = NULL_TREE; - if (ffebld_arrter_pad (expr) == 0) - item = NULL_TREE; - else - { - assert (bt == FFEINFO_basictypeCHARACTER - && kt == FFEINFO_kindtypeCHARACTER1); - - /* Becomes PURPOSE first time through loop. */ - item = build_int_2 (ffebld_arrter_pad (expr), 0); - } - - 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) - /* Assume item is PURPOSE first time through loop. */ - list = item = build_tree_list (item, t); - else - { - TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); - item = TREE_CHAIN (item); - } - } - } - - item = build_int_2 ((ffebld_arrter_size (expr) - + ffebld_arrter_pad (expr)) - 1, 0); - 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - return list; - - case FFEBLD_opCONTER: - assert (ffebld_conter_pad (expr) == 0); - 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) - { - /* xgettext:no-c-format */ - 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: - return ffecom_arrayref_ (NULL_TREE, expr, 0); - - case FFEBLD_opUPLUS: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - return ffecom_1 (NOP_EXPR, tree_type, left); - - case FFEBLD_opPAREN: - /* ~~~Make sure Fortran rules respected here */ - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - return ffecom_1 (NOP_EXPR, tree_type, left); - - case FFEBLD_opUMINUS: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - } - return ffecom_1 (NEGATE_EXPR, tree_type, left); - - case FFEBLD_opADD: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (PLUS_EXPR, tree_type, left, right); - - case FFEBLD_opSUBTRACT: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (MINUS_EXPR, tree_type, left, right); - - case FFEBLD_opMULTIPLY: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_2 (MULT_EXPR, tree_type, left, right); - - case FFEBLD_opDIVIDE: - left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp); - right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp); - if (tree_type_x) - { - tree_type = tree_type_x; - left = convert (tree_type, left); - right = convert (tree_type, right); - } - return ffecom_tree_divide_ (tree_type, left, right, - dest_tree, dest, dest_used, - ffebld_nonter_hook (expr)); - - case FFEBLD_opPOWER: - { - ffebld left = ffebld_left (expr); - ffebld right = ffebld_right (expr); - ffecomGfrt code; - ffeinfoKindtype rtkt; - ffeinfoKindtype ltkt; - bool ref = TRUE; - - switch (ffeinfo_basictype (ffebld_info (right))) - { - - case FFEINFO_basictypeINTEGER: - if (1 || optimize) - { - item = ffecom_expr_power_integer_ (expr); - 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; - ltkt = FFEINFO_kindtypeINTEGER4; - rtkt = FFEINFO_kindtypeINTEGER4; - } - else - { - code = FFECOM_gfrtPOW_II; - ltkt = FFEINFO_kindtypeINTEGER1; - } - break; - - case FFEINFO_basictypeREAL: - if (ffeinfo_kindtype (ffebld_info (left)) - == FFEINFO_kindtypeREAL1) - { - code = FFECOM_gfrtPOW_RI; - ltkt = FFEINFO_kindtypeREAL1; - } - else - { - code = FFECOM_gfrtPOW_DI; - ltkt = FFEINFO_kindtypeREAL2; - } - break; - - case FFEINFO_basictypeCOMPLEX: - if (ffeinfo_kindtype (ffebld_info (left)) - == FFEINFO_kindtypeREAL1) - { - code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL1; - } - else - { - code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL2; - } - break; - - default: - assert ("bad pow_*i" == NULL); - code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ - ltkt = FFEINFO_kindtypeREAL1; - break; - } - if (ffeinfo_kindtype (ffebld_info (left)) != ltkt) - left = ffeexpr_convert (left, NULL, NULL, - ffeinfo_basictype (ffebld_info (left)), - ltkt, 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); - /* We used to call FFECOM_gfrtPOW_DD here, - which passes arguments by reference. */ - code = FFECOM_gfrtL_POW; - /* Pass arguments by value. */ - ref = FALSE; - 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. */ - ref = TRUE; /* Pass arguments by reference. */ - 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, ref, - ffebld_nonter_hook (expr)); - } - - case FFEBLD_opNOT: - 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: - 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); - - if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) - args = ffecom_list_expr (ffebld_right (expr)); - else - args = ffecom_list_ptr_to_expr (ffebld_right (expr)); - - if (args == error_mark_node) - return error_mark_node; - - 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, - ffebld_nonter_hook (expr)); - TREE_SIDE_EFFECTS (item) = 1; - return item; - - case FFEBLD_opAND: - 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: - 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: - 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: - 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; - - 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: /* :::::::::::::::::::: */ - 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: - { - 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) - 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, NULL_TREE); - item = ffecom_2 (code, integer_type_node, - item, - convert (TREE_TYPE (item), - integer_zero_node)); - } - item = convert (tree_type, item); - } - - return item; - - default: - assert ("relational bad basictype" == NULL); - /* Fall through. */ - case FFEINFO_basictypeANY: - return error_mark_node; - } - break; - - case FFEBLD_opPERCENT_LOC: - item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list); - return convert (tree_type, item); - - case FFEBLD_opPERCENT_VAL: - item = ffecom_arg_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 -} - -/* 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. */ - -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)), - NULL_TREE), - 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))), - NULL_TREE) - )) - ); -#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_)))), - NULL_TREE), - 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))), - NULL_TREE)) - ) - ); -#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: - tempvar = ffebld_nonter_hook (expr); - assert (tempvar); - { - 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) - /* We used to call FFECOM_gfrtALOG10 here. */ - gfrt = FFECOM_gfrtL_LOG10; - else if (kt == FFEINFO_kindtypeREAL2) - /* We used to call FFECOM_gfrtDLOG10 here. */ - gfrt = FFECOM_gfrtL_LOG10; - 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) - /* We used to call FFECOM_gfrtAMOD here. */ - gfrt = FFECOM_gfrtL_FMOD; - else if (kt == FFEINFO_kindtypeREAL2) - /* We used to call FFECOM_gfrtDMOD here. */ - gfrt = FFECOM_gfrtL_FMOD; - 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 target_true; - ffetargetLogical1 target_false; - tree true_tree; - tree false_tree; - - ffetarget_logical1 (&target_true, TRUE); - ffetarget_logical1 (&target_false, FALSE); - if (target_true == 1) - true_tree = convert (tree_type, integer_one_node); - else - true_tree = convert (tree_type, build_int_2 (target_true, 0)); - if (target_false == 0) - false_tree = convert (tree_type, integer_zero_node); - else - false_tree = convert (tree_type, build_int_2 (target_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)))); - /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - } - 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)))); - /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */ - expr_tree - = ffecom_3 (COND_EXPR, tree_type, - ffecom_truth_value - (ffecom_2 (NE_EXPR, integer_type_node, - ffecom_1 (ABS_EXPR, - integer_type_node, - arg2_tree), - TYPE_SIZE (uns_type))), - expr_tree, - convert (tree_type, integer_zero_node)); - /* 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); - /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - 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; - - 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 (NULL_TREE, 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))); - - 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); - /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */ - 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)); - 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); - /* Fix up (twice), because LSHIFT_EXPR above - can't shift over TYPE_SIZE. */ - 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); - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); - - if (arg2 != NULL) - arg2_tree = ffecom_expr_w (NULL_TREE, arg2); - else - arg2_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - - 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, - ffebld_nonter_hook (expr)); - - 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; - - 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_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); - - arg2_tree = ffecom_ptr_to_expr (arg2); - - if (arg3 != NULL) - arg3_tree = ffecom_expr_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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; - - 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); - if (arg3 != NULL) - arg3_tree = ffecom_expr_w (NULL_TREE, arg3); - else - arg3_tree = NULL_TREE; - - 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, - ffebld_nonter_hook (expr)); - 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_impFSTAT_subr: - { - tree arg1_tree; - tree arg2_tree; - tree arg3_tree; - - 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_w (NULL_TREE, arg3); - - 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, - ffebld_nonter_hook (expr)); - 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; - - 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_w (NULL_TREE, arg3); - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len); - - arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ? - ffecom_f2c_longint_type_node : - ffecom_f2c_integer_type_node), - ffecom_expr (arg1)); - arg2_tree = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (arg2_tree)), - arg2_tree); - - 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, - ffebld_nonter_hook (expr)); - TREE_SIDE_EFFECTS (expr_tree) = 1; - } - 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_real_type_node), - arg1_tree, - dest_tree, dest, dest_used, - NULL_TREE, TRUE, - ffebld_nonter_hook (expr)); - } - return expr_tree; - - case FFEINTRIN_impFTELL_subr: - case FFEINTRIN_impUMASK_subr: - { - tree arg1_tree; - tree arg2_tree; - - 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_w (NULL_TREE, arg2); - - 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, - ffebld_nonter_hook (expr)); - 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; - - arg1_tree = ffecom_expr_w (NULL_TREE, arg1); - - expr_tree - = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), - ffecom_gfrt_kindtype (gfrt), - FALSE, - NULL_TREE, - NULL_TREE, - NULL_TREE, NULL, NULL, NULL_TREE, TRUE, - ffebld_nonter_hook (expr)); - - 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 result_tree; - - result_tree = ffecom_expr_w (NULL_TREE, arg2); - - arg1_tree = ffecom_ptr_to_expr (arg1); - - 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, - ffebld_nonter_hook (expr)); - expr_tree = ffecom_modify (NULL_TREE, result_tree, - convert (TREE_TYPE (result_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_impDATE_AND_TIME: - 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! */ - - expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), - ffebld_right (expr)); - - 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, - ffebld_nonter_hook (expr)); - - /* See bottom of this file for f2c transforms used to determine - many of the above implementations. The info seems to confuse - Emacs's C mode indentation, which is why it's been moved to - the bottom of this source file. */ -} - -/* 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). */ - -static tree -ffecom_expr_power_integer_ (ffebld expr) -{ - tree l = ffecom_expr (ffebld_left (expr)); - tree r = ffecom_expr (ffebld_right (expr)); - 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, NULL_TREE); - 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, - ffebld_nonter_hook (expr)); - 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 divide; - tree basetypeof_l_is_int; - tree se; - tree t; - - basetypeof_l_is_int - = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); - - se = expand_start_stmt_expr (/*has_scope=*/1); - - ffecom_start_compstmt (); - - rtmp = ffecom_make_tempvar ("power_r", rtype, - FFETARGET_charactersizeNONE, -1); - ltmp = ffecom_make_tempvar ("power_l", ltype, - FFETARGET_charactersizeNONE, -1); - result = ffecom_make_tempvar ("power_res", ltype, - FFETARGET_charactersizeNONE, -1); - if (TREE_CODE (ltype) == COMPLEX_TYPE - || TREE_CODE (ltype) == RECORD_TYPE) - divide = ffecom_make_tempvar ("power_div", ltype, - FFETARGET_charactersizeNONE, -1); - else - divide = NULL_TREE; - - 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, - divide))); - 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, - divide))); - 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); - - t = ffecom_end_compstmt (); - - result = expand_end_stmt_expr (se); - - /* This code comes from c-parse.in, after its expand_end_stmt_expr. */ - - if (TREE_CODE (t) == BLOCK) - { - /* Make a BIND_EXPR for the BLOCK already made. */ - result = build (BIND_EXPR, TREE_TYPE (result), - NULL_TREE, result, t); - /* Remove the block from the tree at this point. - It gets put back at the proper place - when the BIND_EXPR is expanded. */ - delete_block (t); - } - else - result = t; - } - - return result; -} - -/* ffecom_expr_transform_ -- Transform symbols in expr - - ffebld expr; // FFE expression. - ffecom_expr_transform_ (expr); - - Recursive descent on expr while transforming any untransformed SYMTERs. */ - -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; -} - -/* Make a type based on info in live f2c.h file. */ - -static void -ffecom_f2c_make_type_ (tree *type, int tcode, const 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), - *type)); -} - -/* 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 - && compare_tree_int (TYPE_SIZE (t), size) == 0) - { - assert (code != -1); - ffecom_f2c_typecode_[bt][j] = code; - code = -1; - } -} - -/* Finish up globals after doing all program units in file - - Need to handle only uninitialized COMMON areas. */ - -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. */ - - DECL_EXTERNAL (cbt) = 0; - - /* Give the array a size now. */ - - size = build_int_2 ((ffeglobal_common_size (global) - + ffeglobal_common_pad (global)) - 1, - 0); - - cbtype = TREE_TYPE (cbt); - TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, - integer_zero_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; -} - -/* Finish up any untransformed symbols. */ - -static ffesymbol -ffecom_finish_symbol_transform_ (ffesymbol s) -{ - if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK)) - 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) - { - if (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)) - { - /* 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)); - } - - return s; -} - -/* 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. */ - -static tree -ffecom_get_appended_identifier_ (char us, const 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; -} - -/* Decide whether to append underscore to name before calling - get_identifier. */ - -static tree -ffecom_get_external_identifier_ (ffesymbol s) -{ - char us; - const 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) - || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) - || (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); -} - -/* 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. */ - -static tree -ffecom_get_identifier_ (const 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); -} - -/* 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. */ - -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; - location_t old_loc = input_location; - - 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); - input_line = 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; - - push_f_function_context (); - - 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. */ - - 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"); - - 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); - - 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_prepare_let_char_ (sz, expr); - - ffecom_prepare_end (); - - ffecom_let_char_ (result, result_length, sz, expr); - expand_null_return (); - } - else - { - ffecom_prepare_expr (expr); - - ffecom_prepare_end (); - - expand_return (ffecom_modify (NULL_TREE, - DECL_RESULT (current_function_decl), - ffecom_expr (expr))); - } - } - - ffecom_end_compstmt (); - - func = current_function_decl; - finish_function (1); - - pop_f_function_context (); - - recurse = FALSE; - - input_location = old_loc; - - ffecom_nested_entry_ = NULL; - - return func; -} - -static const char * -ffecom_gfrt_args_ (ffecomGfrt ix) -{ - return ffecom_gfrt_argstring_[ix]; -} - -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]); -} - -/* Return initialize-to-zero expression for this VAR_DECL. */ - -/* A somewhat evil way to prevent the garbage collector - from collecting 'tree' structures. */ -#define NUM_TRACKED_CHUNK 63 -struct tree_ggc_tracker GTY(()) -{ - struct tree_ggc_tracker *next; - tree trees[NUM_TRACKED_CHUNK]; -}; -static GTY(()) struct tree_ggc_tracker *tracker_head; - -void -ffecom_save_tree_forever (tree t) -{ - int i; - if (tracker_head != NULL) - for (i = 0; i < NUM_TRACKED_CHUNK; i++) - if (tracker_head->trees[i] == NULL) - { - tracker_head->trees[i] = t; - return; - } - - { - /* Need to allocate a new block. */ - struct tree_ggc_tracker *old_head = tracker_head; - - tracker_head = ggc_alloc (sizeof (*tracker_head)); - tracker_head->next = old_head; - tracker_head->trees[0] = t; - for (i = 1; i < NUM_TRACKED_CHUNK; i++) - tracker_head->trees[i] = NULL; - } -} - -static tree -ffecom_init_zero_ (tree decl) -{ - tree init; - int incremental = TREE_STATIC (decl); - tree type = TREE_TYPE (decl); - - if (incremental) - { - make_decl_rtl (decl, NULL); - assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); - } - - 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) - { - init = build_constructor (type, NULL_TREE); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - } - else - { - assemble_zeros (int_size_in_bytes (type)); - init = error_mark_node; - } - - return init; -} - -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_char_args_ (&expr_tree, &length_tree, arg); - - 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; - } -} - -/* 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. */ - -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; -} - -/* Handle CHARACTER assignments. - - 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. */ - -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, NULL_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, NULL_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; - - { - tree hook; - - hook = ffebld_nonter_hook (source); - assert (hook); - assert (TREE_CODE (hook) == TREE_VEC); - assert (TREE_VEC_LENGTH (hook) == 2); - length_array = lengths = TREE_VEC_ELT (hook, 0); - item_array = items = TREE_VEC_ELT (hook, 1); - } - - 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, NULL_TREE); - TREE_SIDE_EFFECTS (expr_tree) = 1; - - expand_expr_stmt (expr_tree); - } - - ffecom_concat_list_kill_ (catlist); -} - -/* 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). */ - -static void -ffecom_make_gfrt_ (ffecomGfrt ix) -{ - tree t; - tree ttype; - - switch (ffecom_gfrt_type_[ix]) - { - case FFECOM_rttypeVOID_: - ttype = void_type_node; - break; - - case FFECOM_rttypeVOIDSTAR_: - ttype = TREE_TYPE (null_pointer_node); /* `void *'. */ - break; - - case FFECOM_rttypeFTNINT_: - ttype = ffecom_f2c_ftnint_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 = double_type_node; - break; - - case FFECOM_rttypeREAL_GNU_: - ttype = float_type_node; - 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_rttypeDOUBLEREAL_: - ttype = ffecom_f2c_doublereal_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_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0; - TREE_PUBLIC (t) = 1; - TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; - - /* Sanity check: A function that's const cannot be volatile. */ - - assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1); - - /* Sanity check: A function that's const cannot return complex. */ - - assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1); - - t = start_decl (t, TRUE); - - finish_decl (t, NULL_TREE, TRUE); - - ffecom_gfrt_[ix] = t; -} - -/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ - -static void -ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) -{ - ffesymbol s = ffestorag_symbol (st); - - if (ffesymbol_namelisted (s)) - ffecom_member_namelisted_ = TRUE; -} - -/* 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. */ - -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; - TREE_USED (t) = 1; - - SET_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); -} - -/* Prepare source expression for assignment into a destination perhaps known - to be of a specific size. */ - -static void -ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source) -{ - ffecomConcatList_ catlist; - int count; - int i; - tree ltmp; - tree itmp; - tree tempvar = NULL_TREE; - - while (ffebld_op (source) == FFEBLD_opCONVERT) - source = ffebld_left (source); - - catlist = ffecom_concat_list_new_ (source, dest_size); - count = ffecom_concat_list_count_ (catlist); - - if (count >= 2) - { - ltmp - = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count); - itmp - = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, count); - - tempvar = make_tree_vec (2); - TREE_VEC_ELT (tempvar, 0) = ltmp; - TREE_VEC_ELT (tempvar, 1) = itmp; - } - - for (i = 0; i < count; ++i) - ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i)); - - ffecom_concat_list_kill_ (catlist); - - if (tempvar) - { - ffebld_nonter_set_hook (source, tempvar); - current_binding_level->prep_state = 1; - } -} - -/* 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). */ - -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; -} - -/* 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. */ - -static void -ffecom_start_progunit_ (void) -{ - 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; - location_t old_loc = input_location; - - assert (fn != NULL); - assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); - - input_filename = ffesymbol_where_filename (fn); - input_line = ffesymbol_where_filelinenum (fn); - - 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)); - } -#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 */ - - TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */ - - if (!altentries - && ((g = ffesymbol_global (fn)) != NULL) - && ((ffeglobal_type (g) == gt) - || (ffeglobal_type (g) == egt))) - { - ffeglobal_set_hook (g, current_function_decl); - } - - /* 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"), - 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"); - - /* 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); - } - - if (TREE_CODE (current_function_decl) != ERROR_MARK) - store_parm_decls (main_program ? 1 : 0); - - ffecom_start_compstmt (); - /* Disallow temp vars at this level. */ - current_binding_level->prep_state = 2; - - input_location = old_loc; - - /* 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_); -} - -/* 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. */ - -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; - location_t old_loc = input_location; - - /* Must ensure special ASSIGN variables are declared at top of outermost - block, else they'll end up in the innermost block when their first - ASSIGN is seen, which leaves them out of scope when they're the - subject of a GOTO or I/O statement. - - We make this variable even if -fugly-assign. Just let it go unused, - in case it turns out there are cases where we really want to use this - variable anyway (e.g. ASSIGN to INTEGER*2 variable). */ - - if (! ffecom_transform_only_dummies_ - && ffesymbol_assigned (s) - && ! ffesymbol_hook (s).assign_tree) - s = ffecom_sym_transform_assign_ (s); - - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - input_line = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); - - input_filename = ffesymbol_where_filename (sf); - input_line = 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); - DECL_ARTIFICIAL (t) = 1; - 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; - } - - 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); - - ffecom_save_tree_forever (t); - - 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; - - type = ffecom_type_localvar_ (s, bt, kt); - - if (type == error_mark_node) - { - t = error_mark_node; - break; - } - - if ((st != NULL) - && (ffestorag_size (st) == 0)) - { - t = error_mark_node; - break; - } - - if ((st != NULL) - && (ffestorag_parent (st) != NULL)) - { /* Child of EQUIVALENCE parent. */ - ffestorag est; - tree et; - 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, /*rescan=*/true); - - 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); - TREE_CONSTANT (t) = staticp (et); - - addr = TRUE; - } - else - { - tree initexpr; - bool init = ffesymbol_is_init (s); - - 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) - { - assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (t), - ffestorag_size (st))); - } - } - } - 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)) - { - 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]); - - break; - } - - 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; - - 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)). */ - /* Even more recently used to set to INT_MAX, but that - broke when some overflow checking went into the back - end. Now we just leave the upper bound unspecified. */ - high = NULL; - } - 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) - || (high && 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 (high && 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 (high && 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); - DECL_ARTIFICIAL (t) = 1; - - /* 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; - - cs = ffesymbol_common (s); /* The COMMON area itself. */ - if (st != NULL) /* Else not laid out. */ - { - ffecom_transform_common_ (cs); - st = ffesymbol_storage (s); - } - - 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; - tree toffset; - - 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)); - toffset = build_int_2 (offset, 0); - TREE_TYPE (toffset) = ssizetype; - t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), - t, toffset); - t = convert (build_pointer_type (type), - t); - TREE_CONSTANT (t) = 1; - - addr = TRUE; - } - } - 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; - } - - 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); - - ffecom_save_tree_forever (t); - - 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); - DECL_ARTIFICIAL (t) = 1; - 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; - } - - 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, ffe_is_globals ()); - finish_decl (t, NULL_TREE, ffe_is_globals ()); - - if ((g != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) - ffeglobal_set_hook (g, t); - - ffecom_save_tree_forever (t); - - 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); - DECL_ARTIFICIAL (t) = 1; - 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_); - - 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); - - ffecom_save_tree_forever (t); - - 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; - - input_location = old_loc; - - return s; -} - -/* 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. */ - -static ffesymbol -ffecom_sym_transform_assign_ (ffesymbol s) -{ - tree t; /* Transformed thingy. */ - location_t old_loc = input_location; - - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - input_line = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); - - input_filename = ffesymbol_where_filename (sf); - input_line = ffesymbol_where_filelinenum (sf); - } - - assert (!ffecom_transform_only_dummies_); - - t = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_ASSIGN_%s", - ffesymbol_text (s)), - 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); - - ffesymbol_hook (s).assign_tree = t; - - input_location = old_loc; - - return s; -} - -/* 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). */ - -static void -ffecom_transform_common_ (ffesymbol s) -{ - ffestorag st = ffesymbol_storage (s); - ffeglobal g = ffesymbol_global (s); - tree cbt; - tree cbtype; - tree init; - tree high; - 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))) - { - if (st->hook == NULL) ffestorag_set_hook (st, cbt); - return; - } - - /* Process inits. */ - - if (is_init) - { - if (ffestorag_init (st) != NULL) - { - ffebld sexp; - - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (st))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (st)); - break; - - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (st)); - break; - - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (st)); - break; - - default: - assert ("bad op for cmn init (pad)" == NULL); - break; - } - - init = ffecom_expr (sexp); - 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; - - /* cbtype must be permanently allocated! */ - - /* Allocate the MAX of the areas so far, seen filewide. */ - high = build_int_2 ((ffeglobal_common_size (g) - + ffeglobal_common_pad (g)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; - - if (init) - cbtype = build_array_type (char_type_node, - build_range_type (integer_type_node, - integer_zero_node, - high)); - 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; - DECL_USER_ALIGN (cbt) = 0; - - 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) - { - assert (DECL_SIZE_UNIT (cbt) != NULL_TREE); - assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt), - (ffeglobal_common_size (g) - + ffeglobal_common_pad (g)))); - } - - ffeglobal_set_hook (g, cbt); - - ffestorag_set_hook (st, cbt); - - ffecom_save_tree_forever (cbt); -} - -/* Make master area for local EQUIVALENCE. */ - -static void -ffecom_transform_equiv_ (ffestorag eqst) -{ - tree eqt; - tree eqtype; - tree init; - tree high; - bool is_init = ffestorag_is_init (eqst); - - assert (eqst != NULL); - - eqt = ffestorag_hook (eqst); - - if (eqt != NULL_TREE) - return; - - /* Process inits. */ - - if (is_init) - { - if (ffestorag_init (eqst) != NULL) - { - ffebld sexp; - - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (eqst))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst)); - break; - - default: - assert ("bad op for eqv init (pad)" == NULL); - break; - } - - init = ffecom_expr (sexp); - 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); - - high = build_int_2 ((ffestorag_size (eqst) - + ffestorag_modulo (eqst)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; - - eqtype = build_array_type (char_type_node, - build_range_type (ffecom_integer_type_node, - ffecom_integer_zero_node, - high)); - - eqt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_equiv_%s", - ffesymbol_text - (ffestorag_symbol (eqst))), - 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; - TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */ - 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 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; - DECL_USER_ALIGN (eqt) = 0; - - 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 ()); - - { - assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST); - assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt), - (ffestorag_size (eqst) - + ffestorag_modulo (eqst)))); - } - - ffestorag_set_hook (eqst, eqt); - - ffestorag_drive (ffestorag_list_equivs (eqst), - &ffecom_member_phase2_, - eqst); -} - -/* Implement NAMELIST in back end. See f2c/format.c for more info. */ - -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 i; - static int mynumber = 0; - - nmlt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_namelist_%d", - 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, nmlinits); - TREE_CONSTANT (nmlinits) = 1; - TREE_STATIC (nmlinits) = 1; - - finish_decl (nmlt, nmlinits, FALSE); - - nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); - - return nmlt; -} - -/* 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. */ - -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 = fold (build (PLUS_EXPR, TREE_TYPE (*offset), - *offset, TREE_OPERAND (t, 1))); - /* Convert offset (presumably in bytes) into canonical units - (presumably bits). */ - *offset = size_binop (MULT_EXPR, - convert (bitsizetype, *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 = bitsize_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 = bitsize_zero_node; - break; - } - /* Fall through. */ - default: - /* Not a COMMON reference, so an unrecognized pattern. */ - *decl = error_mark_node; - break; - } -} - -/* 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. */ - -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 NEGATE_EXPR: - case MIN_EXPR: - case MAX_EXPR: - case ABS_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_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 = bitsize_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; - - /* Calculate ((element - base) * NBBY) + init_offset. */ - *offset = fold (build (MINUS_EXPR, TREE_TYPE (element), - element, - TYPE_MIN_VALUE (TYPE_DOMAIN - (TREE_TYPE (array))))); - - *offset = size_binop (MULT_EXPR, - convert (bitsizetype, *offset), - TYPE_SIZE (TREE_TYPE (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; - } -} - -/* Do divide operation appropriate to type of operands. */ - -static tree -ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree, - ffebld dest, bool *dest_used, tree hook) -{ - 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: - if (! optimize_size) - return ffecom_2 (RDIV_EXPR, tree_type, - left, - right); - { - 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, hook); - } - 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, hook); - } - break; - - default: - return ffecom_2 (RDIV_EXPR, tree_type, - left, - right); - } -} - -/* Build type info for non-dummy variable. */ - -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; -} - -/* Build Namelist type. */ - -static GTY(()) tree ffecom_type_namelist_var; -static tree -ffecom_type_namelist_ (void) -{ - if (ffecom_type_namelist_var == NULL_TREE) - { - tree namefield, varsfield, nvarsfield, vardesctype, type; - - vardesctype = ffecom_type_vardesc_ (); - - 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); - - ffecom_type_namelist_var = type; - } - - return ffecom_type_namelist_var; -} - -/* Build Vardesc type. */ - -static GTY(()) tree ffecom_type_vardesc_var; -static tree -ffecom_type_vardesc_ (void) -{ - if (ffecom_type_vardesc_var == NULL_TREE) - { - tree namefield, addrfield, dimsfield, typefield, type; - 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_ptr_to_ftnlen_type_node); - typefield = ffecom_decl_field (type, dimsfield, "type", - integer_type_node); - - TYPE_FIELDS (type) = namefield; - layout_type (type); - - ffecom_type_vardesc_var = type; - } - - return ffecom_type_vardesc_var; -} - -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; - static int mynumber = 0; - - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_vardesc_%d", - 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, varinits); - TREE_CONSTANT (varinits) = 1; - TREE_STATIC (varinits) = 1; - - finish_decl (var, varinits, FALSE); - - var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); - - ffesymbol_hook (s).vardesc_tree = var; - } - - return ffesymbol_hook (s).vardesc_tree; -} - -static tree -ffecom_vardesc_array_ (ffesymbol s) -{ - ffebld b; - tree list; - tree item = NULL_TREE; - tree var; - int i; - 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); - } - } - - 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, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - - var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", 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); - - return var; -} - -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; - 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; - - 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, numdim); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; - - var = ffecom_get_invented_identifier ("__g77_dims_%d", 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); - - return var; - } -} - -/* 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. */ - -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 (!ffe_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; - else if (code == INDIRECT_REF) - TREE_READONLY (item) = TYPE_READONLY (type); - return fold (item); -} - -/* 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). */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. */ - -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, 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); -} - -/* 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. */ - -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; -} - -/* 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. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. */ - -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); -} - -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ - -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); -} - -/* 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). */ - -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); -} - -/* Transform expression into constant argument-pointer-to-expression tree. - - If the expression can be transformed into a argument-pointer-to-expression - tree that is constant, that is done, and the tree returned. Else - NULL_TREE is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - { - if (length) - *length = error_mark_node; - return error_mark_node; - } - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereCOMMON - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_arg_ptr_to_expr (expr, length); - assert (TREE_CONSTANT (t)); - assert (! length || TREE_CONSTANT (*length)); - return t; - } - - if (length - && ffebld_size (expr) != FFETARGET_charactersizeNONE) - *length = build_int_2 (ffebld_size (expr), 0); - else if (length) - *length = NULL_TREE; - return NULL_TREE; -} - -/* 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 the length argument is NULL, this is a slightly special - case of building a FORMAT expression, that is, an expression that - will be used at run time without regard to length. For the current - implementation, which uses the libf2c library, this means it is nice - to append a null byte to the end of the expression, where feasible, - to make sure any diagnostic about the FORMAT string terminates at - some useful point. - - For now, treat %REF(char-expr) as the same as char-expr with a NULL - length argument. This might even be seen as a feature, if a null - byte can always be appended. */ - -tree -ffecom_arg_ptr_to_expr (ffebld expr, tree *length) -{ - tree item; - tree ign_length; - ffecomConcatList_ catlist; - - if (length != NULL) - *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); - if (temp_exp == error_mark_node) - return error_mark_node; - - 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)); - if (length != NULL) - { - ign_length = NULL_TREE; - length = &ign_length; - } - expr = ffebld_left (expr); - break; - - case FFEBLD_opPERCENT_DESCR: - switch (ffeinfo_basictype (ffebld_info (expr))) - { - 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; - } - - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_ptr_to_expr (expr); - - assert (ffeinfo_kindtype (ffebld_info (expr)) - == FFEINFO_kindtypeCHARACTER1); - - while (ffebld_op (expr) == FFEBLD_opPAREN) - expr = ffebld_left (expr); - - catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); - switch (ffecom_concat_list_count_ (catlist)) - { - case 0: /* Shouldn't happen, but in case it does... */ - if (length != NULL) - { - *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. */ - if (length == NULL) - ffecom_char_args_with_null_ (&item, &ign_length, - ffecom_concat_list_expr_ (catlist, 0)); - else - 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; - - sz = ffecom_concat_list_maxlen_ (catlist); - /* ~~Kludge! */ - assert (sz != FFETARGET_charactersizeNONE); - - { - tree hook; - - hook = ffebld_nonter_hook (expr); - assert (hook); - assert (TREE_CODE (hook) == TREE_VEC); - assert (TREE_VEC_LENGTH (hook) == 3); - length_array = lengths = TREE_VEC_ELT (hook, 0); - item_array = items = TREE_VEC_ELT (hook, 1); - temporary = TREE_VEC_ELT (hook, 2); - } - - known_length = ffecom_f2c_ftnlen_zero_node; - - for (i = 0; i < count; ++i) - { - if ((i == count) - && (length == NULL)) - ffecom_char_args_with_null_ (&citem, &clength, - ffecom_concat_list_expr_ (catlist, i)); - else - 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); - if (length != NULL) - 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); - } - - 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, NULL_TREE); - TREE_SIDE_EFFECTS (item) = 1; - item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), - item, - temporary); - - if (length != NULL) - *length = known_length; - } - - ffecom_concat_list_kill_ (catlist); - assert (item != NULL_TREE); - return item; -} - -/* Generate call to run-time function. - - 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). */ - -tree -ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook) -{ - 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, hook); -} - -/* Transform constant-union to tree. */ - -tree -ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, - ffeinfoKindtype kt, tree tree_type) -{ - tree item; - - switch (bt) - { - case FFEINFO_basictypeINTEGER: - { - HOST_WIDE_INT hi, lo; - - switch (kt) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - lo = ffebld_cu_val_integer1 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - lo = ffebld_cu_val_integer2 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - lo = ffebld_cu_val_integer3 (*cu); - hi = (lo < 0) ? -1 : 0; - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: -#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT - { - long long int big = ffebld_cu_val_integer4 (*cu); - hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT); - lo = (HOST_WIDE_INT) big; - } -#else - lo = ffebld_cu_val_integer4 (*cu); - hi = (lo < 0) ? -1 : 0; -#endif - break; -#endif - - default: - assert ("bad INTEGER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_int_2 (lo, hi); - 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 - - 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 - - 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; -} - -/* Transform constant-union to tree, with the type known. */ - -tree -ffecom_constantunion_with_type (ffebldConstantUnion *cu, tree tree_type, - ffebldConst ct) -{ - tree item; - - int val; - - switch (ct) - { -#if FFETARGET_okINTEGER1 - case FFEBLD_constINTEGER1: - val = ffebld_cu_val_integer1 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER2 - case FFEBLD_constINTEGER2: - val = ffebld_cu_val_integer2 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER3 - case FFEBLD_constINTEGER3: - val = ffebld_cu_val_integer3 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okINTEGER4 - case FFEBLD_constINTEGER4: -#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT - { - long long int big = ffebld_cu_val_integer4 (*cu); - item = build_int_2 ((HOST_WIDE_INT) big, - (HOST_WIDE_INT) - (big >> HOST_BITS_PER_WIDE_INT)); - } -#else - val = ffebld_cu_val_integer4 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); -#endif - break; -#endif -#if FFETARGET_okLOGICAL1 - case FFEBLD_constLOGICAL1: - val = ffebld_cu_val_logical1 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL2 - case FFEBLD_constLOGICAL2: - val = ffebld_cu_val_logical2 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL3 - case FFEBLD_constLOGICAL3: - val = ffebld_cu_val_logical3 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif -#if FFETARGET_okLOGICAL4 - case FFEBLD_constLOGICAL4: - val = ffebld_cu_val_logical4 (*cu); - item = build_int_2 (val, (val < 0) ? -1 : 0); - break; -#endif - default: - assert ("constant type not supported"==NULL); - return error_mark_node; - break; - } - - TREE_TYPE (item) = tree_type; - - TREE_CONSTANT (item) = 1; - - return item; -} -/* Transform expression into constant tree. - - If the expression can be transformed into a tree that is constant, - that is done, and the tree returned. Else NULL_TREE is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_const_expr (ffebld expr) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - return error_mark_node; - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_expr (expr); - assert (TREE_CONSTANT (t)); - return t; - } - - return NULL_TREE; -} - -/* Handy way to make a field in a struct/union. */ - -tree -ffecom_decl_field (tree context, tree prevfield, const char *name, tree type) -{ - tree field; - - field = build_decl (FIELD_DECL, get_identifier (name), type); - DECL_CONTEXT (field) = context; - DECL_ALIGN (field) = 0; - DECL_USER_ALIGN (field) = 0; - if (prevfield != NULL_TREE) - TREE_CHAIN (prevfield) = field; - - return field; -} - -void -ffecom_close_include (FILE *f) -{ - ffecom_close_include_ (f); -} - -/* End a compound statement (block). */ - -tree -ffecom_end_compstmt (void) -{ - return bison_rule_compstmt_ (); -} - -/* 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 (void) -{ - ffebld item; - - if (ffe_is_ffedebug ()) - fprintf (dmpout, "; end_stmt_transition\n"); - - ffecom_list_blockdata_ = NULL; - ffecom_list_common_ = NULL; - - ffesymbol_drive (ffecom_sym_end_transition); - if (ffe_is_ffedebug ()) - { - ffestorag_report (); - } - - ffecom_start_progunit_ (); - - for (item = ffecom_list_blockdata_; - item != NULL; - item = ffebld_trail (item)) - { - ffebld callee; - ffesymbol s; - tree dt; - tree t; - tree var; - 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; - } - - dt = build_pointer_type (TREE_TYPE (t)); - - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_forceload_%d", - 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); - } - - /* 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; -} - -/* 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 (void) -{ - 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 (); - } - - if (inhibited) - ffebad_set_inhibit (TRUE); -} - -/* Handle assignment statement. - - Convert dest and source using ffecom_expr, then join them - with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ - -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; - tree assign_temp; - - /* This attempts to replicate the test below, but must not be - true when the test below is false. (Always err on the side - of creating unused temporaries, to avoid ICEs.) */ - if (ffebld_op (dest) != FFEBLD_opSYMTER - || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree) - && (TREE_CODE (dest_tree) != VAR_DECL - || TREE_ADDRESSABLE (dest_tree)))) - { - ffecom_prepare_expr_ (source, dest); - dest_used = TRUE; - } - else - { - ffecom_prepare_expr_ (source, NULL); - dest_used = FALSE; - } - - ffecom_prepare_expr_w (NULL_TREE, dest); - - /* For COMPLEX assignment like C1=C2, if partial overlap is possible, - create a temporary through which the assignment is to take place, - since MODIFY_EXPR doesn't handle partial overlap properly. */ - if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX - && ffecom_possible_partial_overlap_ (dest, source)) - { - assign_temp = ffecom_make_tempvar ("complex_let", - ffecom_tree_type - [ffebld_basictype (dest)] - [ffebld_kindtype (dest)], - FFETARGET_charactersizeNONE, - -1); - } - else - assign_temp = NULL_TREE; - - ffecom_prepare_end (); - - dest_tree = ffecom_expr_w (NULL_TREE, 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, FALSE); - else - { - assert (! dest_used); - dest_used = FALSE; - source_tree = ffecom_expr (source); - } - if (source_tree == error_mark_node) - return; - - if (dest_used) - expr_tree = source_tree; - else if (assign_temp) - { - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - assign_temp, - source_tree); - expand_expr_stmt (expr_tree); - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - dest_tree, - assign_temp); - } - else - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - dest_tree, - source_tree); - - expand_expr_stmt (expr_tree); - return; - } - - ffecom_prepare_let_char_ (ffebld_size_known (dest), source); - ffecom_prepare_expr_w (NULL_TREE, dest); - - ffecom_prepare_end (); - - ffecom_char_args_ (&dest_tree, &dest_length, dest); - ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), - source); -} - -/* 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. */ - -tree -ffecom_expr (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE); -} - -/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ - -tree -ffecom_expr_assign (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} - -/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ - -tree -ffecom_expr_assign_w (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} - -/* 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. */ - -tree -ffecom_expr_rw (tree type, ffebld expr) -{ - assert (expr != NULL); - /* Different target types not yet supported. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - return stabilize_reference (ffecom_expr (expr)); -} - -/* Transform expr for use as into 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. */ - -tree -ffecom_expr_w (tree type, ffebld expr) -{ - assert (expr != NULL); - /* Different target types not yet supported. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - return stabilize_reference (ffecom_expr (expr)); -} - -/* Do global stuff. */ - -void -ffecom_finish_compile (void) -{ - assert (ffecom_outer_function_decl_ == NULL_TREE); - assert (current_function_decl == NULL_TREE); - - ffeglobal_drive (ffecom_finish_global_); -} - -/* Public entry point for front end to access finish_decl. */ - -void -ffecom_finish_decl (tree decl, tree init, bool is_top_level) -{ - assert (!is_top_level); - finish_decl (decl, init, FALSE); -} - -/* Finish a program unit. */ - -void -ffecom_finish_progunit (void) -{ - ffecom_end_compstmt (); - - ffecom_previous_function_decl_ = current_function_decl; - ffecom_which_entrypoint_decl_ = NULL_TREE; - - finish_function (0); -} - -/* Wrapper for get_identifier. pattern is sprintf-like. */ - -tree -ffecom_get_invented_identifier (const char *pattern, ...) -{ - tree decl; - char *nam; - va_list ap; - - va_start (ap, pattern); - if (vasprintf (&nam, pattern, ap) == 0) - abort (); - va_end (ap); - decl = get_identifier (nam); - free (nam); - IDENTIFIER_INVENTED (decl) = 1; - return decl; -} - -ffeinfoBasictype -ffecom_gfrt_basictype (ffecomGfrt gfrt) -{ - assert (gfrt < FFECOM_gfrt); - - switch (ffecom_gfrt_type_[gfrt]) - { - case FFECOM_rttypeVOID_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_basictypeNONE; - - case FFECOM_rttypeFTNINT_: - 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_: - case FFECOM_rttypeDOUBLEREAL_: - 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_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_kindtypeNONE; - - case FFECOM_rttypeFTNINT_: - 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_: - case FFECOM_rttypeDOUBLEREAL_: - 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 (void) -{ - tree endlink; - int i; - int j; - tree t; - tree field; - ffetype type; - ffetype base_type; - tree double_ftype_double, double_ftype_double_double; - tree float_ftype_float, float_ftype_float_float; - tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble; - tree ffecom_tree_ptr_to_fun_type_void; - - /* 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 const char names[][12] - = - {"bar", "bletch", "foo", "foobar"}; - const char *name; - unsigned long ul; - double fl; - - name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), - (int (*)(const void *, const void *)) strcmp); - if (name != &names[2][0]) - { - 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 (); - } - } - - 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; - /* Make the binding_level structure for global names. */ - pushlevel (0); - global_binding_level = current_binding_level; - current_binding_level->prep_state = 2; - - build_common_tree_nodes (1); - - /* Define `int' and `char' first so that dbx will output them first. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), - integer_type_node)); - /* CHARACTER*1 is unsigned in ICHAR contexts. */ - char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), - char_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), - long_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), - unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), - long_unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), - long_long_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), - long_long_unsigned_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), - short_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), - short_unsigned_type_node)); - - /* Set the sizetype before we make other types. This *should* be the - first type we create. */ - - set_sizetype - (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE)))); - ffecom_typesize_pointer_ - = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT; - - build_common_tree_nodes_2 (0); - - /* Define both `signed char' and `unsigned char'. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), - signed_char_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), - unsigned_char_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), - float_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), - double_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), - long_double_type_node)); - - /* For now, override what build_common_tree_nodes has done. */ - complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); - complex_float_type_node = ffecom_make_complex_type_ (float_type_node); - complex_double_type_node = ffecom_make_complex_type_ (double_type_node); - complex_long_double_type_node - = ffecom_make_complex_type_ (long_double_type_node); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), - complex_integer_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), - complex_float_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), - complex_double_type_node)); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), - complex_long_double_type_node)); - - pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), - void_type_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; - TYPE_USER_ALIGN (void_type_node) = 0; - - 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); - - t = tree_cons (NULL_TREE, float_type_node, endlink); - float_ftype_float = build_function_type (float_type_node, t); - t = tree_cons (NULL_TREE, float_type_node, t); - float_ftype_float_float = build_function_type (float_type_node, t); - - t = tree_cons (NULL_TREE, double_type_node, endlink); - double_ftype_double = build_function_type (double_type_node, t); - t = tree_cons (NULL_TREE, double_type_node, t); - double_ftype_double_double = build_function_type (double_type_node, t); - - t = tree_cons (NULL_TREE, long_double_type_node, endlink); - ldouble_ftype_ldouble = build_function_type (long_double_type_node, t); - t = tree_cons (NULL_TREE, long_double_type_node, t); - ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node, - t); - - 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); - ffecom_typesize_integer1_ = ffetype_size (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_error ("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_); - ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT), - 7, - ffeinfo_type (FFEINFO_basictypeINTEGER, - ffecom_pointer_kind_)); - - 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); - /* ~~~Not really such a type in libf2c, e.g. I/O support? */ - 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_ALIGN (ffecom_multi_fields_[i][j]) = 0; - DECL_USER_ALIGN (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_atanf", float_ftype_float, - BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE); - builtin_function ("__builtin_atan", double_ftype_double, - BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE); - builtin_function ("__builtin_atanl", ldouble_ftype_ldouble, - BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE); - - builtin_function ("__builtin_atan2f", float_ftype_float_float, - BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE); - builtin_function ("__builtin_atan2", double_ftype_double_double, - BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE); - builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble, - BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE); - - builtin_function ("__builtin_cosf", float_ftype_float, - BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE); - builtin_function ("__builtin_cos", double_ftype_double, - BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE); - builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, - BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE); - - builtin_function ("__builtin_expf", float_ftype_float, - BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE); - builtin_function ("__builtin_exp", double_ftype_double, - BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE); - builtin_function ("__builtin_expl", ldouble_ftype_ldouble, - BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE); - - builtin_function ("__builtin_floorf", float_ftype_float, - BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE); - builtin_function ("__builtin_floor", double_ftype_double, - BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE); - builtin_function ("__builtin_floorl", ldouble_ftype_ldouble, - BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE); - - builtin_function ("__builtin_fmodf", float_ftype_float_float, - BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE); - builtin_function ("__builtin_fmod", double_ftype_double_double, - BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE); - builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble, - BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE); - - builtin_function ("__builtin_logf", float_ftype_float, - BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE); - builtin_function ("__builtin_log", double_ftype_double, - BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE); - builtin_function ("__builtin_logl", ldouble_ftype_ldouble, - BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE); - - builtin_function ("__builtin_powf", float_ftype_float_float, - BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE); - builtin_function ("__builtin_pow", double_ftype_double_double, - BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE); - builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble, - BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE); - - builtin_function ("__builtin_sinf", float_ftype_float, - BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE); - builtin_function ("__builtin_sin", double_ftype_double, - BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE); - builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, - BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE); - - builtin_function ("__builtin_sqrtf", float_ftype_float, - BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE); - builtin_function ("__builtin_sqrt", double_ftype_double, - BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE); - builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, - BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE); - - builtin_function ("__builtin_tanf", float_ftype_float, - BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE); - builtin_function ("__builtin_tan", double_ftype_double, - BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE); - builtin_function ("__builtin_tanl", ldouble_ftype_ldouble, - BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE); - - pedantic_lvalues = FALSE; - - 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); - ffecom_float_half_ = build_real (float_type_node, dconsthalf); - ffecom_double_half_ = build_real (double_type_node, dconsthalf); - - /* Do "extern int xargc;". */ - - ffecom_tree_xargc_ = build_decl (VAR_DECL, - get_identifier ("f__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."); - } -#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 -} - -/* ffecom_init_2 -- Initialize - - ffecom_init_2(); */ - -void -ffecom_init_2 (void) -{ - 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_primary_entry_ = NULL; - ffecom_is_altreturning_ = FALSE; - ffecom_func_result_ = NULL_TREE; - ffecom_multi_retval_ = NULL_TREE; -} - -/* 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. */ - -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) - { - tree texpr = ffecom_arg_expr (ffebld_head (expr), &length); - - if (texpr == error_mark_node) - return error_mark_node; - - *plist = build_tree_list (NULL_TREE, texpr); - 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; -} - -/* 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). */ - -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) - { - tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length); - - if (texpr == error_mark_node) - return error_mark_node; - - *plist = build_tree_list (NULL_TREE, texpr); - 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; -} - -/* Obtain gcc's LABEL_DECL tree for label. */ - -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: - glabel = build_decl (VAR_DECL, - ffecom_get_invented_identifier - ("__g77_format_%d", (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) = current_function_decl; - DECL_INITIAL (glabel) = NULL; - make_decl_rtl (glabel, NULL); - expand_decl (glabel); - - ffecom_save_tree_forever (glabel); - - 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; -} - -/* 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. */ - -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); -} - -/* Register source file name. */ - -void -ffecom_file (const char *name) -{ - ffecom_file_ (name); -} - -/* 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 (ffestorag_init (st) == NULL) - { - init = ffestorag_accretion (st); - assert (init != NULL); - ffestorag_set_accretion (st, NULL); - ffestorag_set_accretes (st, 0); - ffestorag_set_init (st, init); - } -} - -/* 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 (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); - ffesymbol_set_init (s, init); - } -} - -/* 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_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; - } - } - } -} - -FILE * -ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) -{ - return ffecom_open_include_ (name, l, c); -} - -/* 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. */ - -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: - return ffecom_arrayref_ (NULL_TREE, expr, 1); - - 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: - 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; -} - -/* Obtain a temp var with given data type. - - 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. */ - -tree -ffecom_make_tempvar (const char *commentary, tree type, - ffetargetCharacterSize size, int elements) -{ - tree t; - static int mynumber; - - assert (current_binding_level->prep_state < 2); - - if (type == error_mark_node) - return error_mark_node; - - 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_%s_%d", - commentary, - mynumber++), - type); - - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); - - return t; -} - -/* Prepare argument pointer to expression. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_arg_ptr_to_expr. */ - -void -ffecom_prepare_arg_ptr_to_expr (ffebld expr) -{ - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* End of preparations. */ - -bool -ffecom_prepare_end (void) -{ - int prep_state = current_binding_level->prep_state; - - assert (prep_state < 2); - current_binding_level->prep_state = 2; - - return (prep_state == 1) ? TRUE : FALSE; -} - -/* Prepare expression. - - This is called before any code is generated for the current block. - It scans the expression, declares any temporaries that might be needed - during evaluation of the expression, and stores those temporaries in - the appropriate "hook" fields of the expression. `dest', if not NULL, - specifies the destination that ffecom_expr_ will see, in case that - helps avoid generating unused temporaries. - - ~~Improve to avoid allocating unused temporaries by taking `dest' - into account vis-a-vis aliasing requirements of complex/character - functions. */ - -void -ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) -{ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffetargetCharacterSize sz; - tree tempvar = NULL_TREE; - - assert (current_binding_level->prep_state < 2); - - if (! expr) - return; - - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); - sz = ffeinfo_size (ffebld_info (expr)); - - /* Generate whatever temporaries are needed to represent the result - of the expression. */ - - if (bt == FFEINFO_basictypeCHARACTER) - { - while (ffebld_op (expr) == FFEBLD_opPAREN) - expr = ffebld_left (expr); - } - - switch (ffebld_op (expr)) - { - default: - /* Don't make temps for SYMTER, CONTER, etc. */ - if (ffebld_arity (expr) == 0) - break; - - switch (bt) - { - case FFEINFO_basictypeCOMPLEX: - if (ffebld_op (expr) == FFEBLD_opFUNCREF) - { - ffesymbol s; - - if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER) - break; - - s = ffebld_symter (ffebld_left (expr)); - if (ffesymbol_where (s) == FFEINFO_whereCONSTANT - || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC - && ! ffesymbol_is_f2c (s)) - || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC - && ! ffe_is_f2c_library ())) - break; - } - else if (ffebld_op (expr) == FFEBLD_opPOWER) - { - /* Requires special treatment. There's no POW_CC function - in libg2c, so POW_ZZ is used, which means we always - need a double-complex temp, not a single-complex. */ - kt = FFEINFO_kindtypeREAL2; - } - else if (ffebld_op (expr) != FFEBLD_opDIVIDE) - /* The other ops don't need temps for complex operands. */ - break; - - /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C), - REAL(C). See 19990325-0.f, routine `check', for cases. */ - tempvar = ffecom_make_tempvar ("complex", - ffecom_tree_type - [FFEINFO_basictypeCOMPLEX][kt], - FFETARGET_charactersizeNONE, - -1); - break; - - case FFEINFO_basictypeCHARACTER: - if (ffebld_op (expr) != FFEBLD_opFUNCREF) - break; - - if (sz == FFETARGET_charactersizeNONE) - /* ~~Kludge alert! This should someday be fixed. */ - sz = 24; - - tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1); - break; - - default: - break; - } - break; - - case FFEBLD_opCONCATENATE: - { - /* This gets special handling, because only one set of temps - is needed for a tree of these -- the tree is treated as - a flattened list of concatenations when generating code. */ - - ffecomConcatList_ catlist; - tree ltmp, itmp, result; - int count; - int i; - - catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); - count = ffecom_concat_list_count_ (catlist); - - if (count >= 2) - { - ltmp - = ffecom_make_tempvar ("concat_len", - ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count); - itmp - = ffecom_make_tempvar ("concat_item", - ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, count); - result - = ffecom_make_tempvar ("concat_res", - char_type_node, - ffecom_concat_list_maxlen_ (catlist), - -1); - - tempvar = make_tree_vec (3); - TREE_VEC_ELT (tempvar, 0) = ltmp; - TREE_VEC_ELT (tempvar, 1) = itmp; - TREE_VEC_ELT (tempvar, 2) = result; - } - - for (i = 0; i < count; ++i) - ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, - i)); - - ffecom_concat_list_kill_ (catlist); - - if (tempvar) - { - ffebld_nonter_set_hook (expr, tempvar); - current_binding_level->prep_state = 1; - } - } - return; - - case FFEBLD_opCONVERT: - if (bt == FFEINFO_basictypeCHARACTER - && ((ffebld_size_known (ffebld_left (expr)) - == FFETARGET_charactersizeNONE) - || (ffebld_size_known (ffebld_left (expr)) >= sz))) - tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1); - break; - } - - if (tempvar) - { - ffebld_nonter_set_hook (expr, tempvar); - current_binding_level->prep_state = 1; - } - - /* Prepare subexpressions for this expr. */ - - switch (ffebld_op (expr)) - { - case FFEBLD_opPERCENT_LOC: - ffecom_prepare_ptr_to_expr (ffebld_left (expr)); - break; - - case FFEBLD_opPERCENT_VAL: - case FFEBLD_opPERCENT_REF: - ffecom_prepare_expr (ffebld_left (expr)); - break; - - case FFEBLD_opPERCENT_DESCR: - ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr)); - break; - - case FFEBLD_opITEM: - { - ffebld item; - - for (item = expr; - item != NULL; - item = ffebld_trail (item)) - if (ffebld_head (item) != NULL) - ffecom_prepare_expr (ffebld_head (item)); - } - break; - - default: - /* Need to handle character conversion specially. */ - switch (ffebld_arity (expr)) - { - case 2: - ffecom_prepare_expr (ffebld_left (expr)); - ffecom_prepare_expr (ffebld_right (expr)); - break; - - case 1: - ffecom_prepare_expr (ffebld_left (expr)); - break; - - default: - break; - } - } - - return; -} - -/* Prepare expression for reading and writing. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_expr_rw. */ - -void -ffecom_prepare_expr_rw (tree type, ffebld expr) -{ - /* This is all we support for now. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Prepare expression for writing. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_expr_w. */ - -void -ffecom_prepare_expr_w (tree type, ffebld expr) -{ - /* This is all we support for now. */ - assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Prepare expression for returning. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_return_expr. */ - -void -ffecom_prepare_return_expr (ffebld expr) -{ - assert (current_binding_level->prep_state < 2); - - if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE - && ffecom_is_altreturning_ - && expr != NULL) - ffecom_prepare_expr (expr); -} - -/* Prepare pointer to expression. - - Like ffecom_prepare_expr, except for expressions to be evaluated - via ffecom_ptr_to_expr. */ - -void -ffecom_prepare_ptr_to_expr (ffebld expr) -{ - /* ~~For now, it seems to be the same thing. */ - ffecom_prepare_expr (expr); - return; -} - -/* Transform expression into constant pointer-to-expression tree. - - If the expression can be transformed into a pointer-to-expression tree - that is constant, that is done, and the tree returned. Else NULL_TREE - is returned. - - That way, a caller can attempt to provide compile-time initialization - of a variable and, if that fails, *then* choose to start a new block - and resort to using temporaries, as appropriate. */ - -tree -ffecom_ptr_to_const_expr (ffebld expr) -{ - if (! expr) - return integer_zero_node; - - if (ffebld_op (expr) == FFEBLD_opANY) - return error_mark_node; - - if (ffebld_arity (expr) == 0 - && (ffebld_op (expr) != FFEBLD_opSYMTER - || ffebld_where (expr) == FFEINFO_whereCOMMON - || ffebld_where (expr) == FFEINFO_whereGLOBAL - || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) - { - tree t; - - t = ffecom_ptr_to_expr (expr); - assert (TREE_CONSTANT (t)); - return t; - } - - return NULL_TREE; -} - -/* 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). */ - -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; -} - -/* Do save_expr only if tree is not error_mark_node. */ - -tree -ffecom_save_tree (tree t) -{ - return save_expr (t); -} - -/* Start a compound statement (block). */ - -void -ffecom_start_compstmt (void) -{ - bison_rule_pushlevel_ (); -} - -/* Public entry point for front end to access start_decl. */ - -tree -ffecom_start_decl (tree decl, bool is_initialized) -{ - DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; - return start_decl (decl, FALSE); -} - -/* 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. */ - -void -ffecom_sym_commit (ffesymbol s UNUSED) -{ - assert (!ffesymbol_retractable ()); -} - -/* 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 ((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_); - } - - /* 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 ((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_); - } - - 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. */ - -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 -} - -/* Create temporary gcc label. */ - -tree -ffecom_temp_label (void) -{ - tree glabel; - static int mynumber = 0; - - glabel = build_decl (LABEL_DECL, - ffecom_get_invented_identifier ("__g77_label_%d", - mynumber++), - void_type_node); - DECL_CONTEXT (glabel) = current_function_decl; - DECL_MODE (glabel) = VOIDmode; - - return glabel; -} - -/* 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. */ - -tree -ffecom_truth_value (tree expr) -{ - return ffe_truthvalue_conversion (expr); -} - -/* 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. */ - -tree -ffecom_truth_value_invert (tree expr) -{ - return invert_truthvalue (ffecom_truth_value (expr)); -} - -/* Return the tree that is the type of the expression, as would be - returned in TREE_TYPE(ffecom_expr(expr)), without otherwise - transforming the expression, generating temporaries, etc. */ - -tree -ffecom_type_expr (ffebld expr) -{ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - tree tree_type; - - assert (expr != NULL); - - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); - tree_type = ffecom_tree_type[bt][kt]; - - switch (ffebld_op (expr)) - { - case FFEBLD_opCONTER: - case FFEBLD_opSYMTER: - case FFEBLD_opARRAYREF: - case FFEBLD_opUPLUS: - case FFEBLD_opPAREN: - case FFEBLD_opUMINUS: - case FFEBLD_opADD: - case FFEBLD_opSUBTRACT: - case FFEBLD_opMULTIPLY: - case FFEBLD_opDIVIDE: - case FFEBLD_opPOWER: - case FFEBLD_opNOT: - case FFEBLD_opFUNCREF: - case FFEBLD_opSUBRREF: - case FFEBLD_opAND: - case FFEBLD_opOR: - case FFEBLD_opXOR: - case FFEBLD_opNEQV: - case FFEBLD_opEQV: - case FFEBLD_opCONVERT: - case FFEBLD_opLT: - case FFEBLD_opLE: - case FFEBLD_opEQ: - case FFEBLD_opNE: - case FFEBLD_opGT: - case FFEBLD_opGE: - case FFEBLD_opPERCENT_LOC: - return tree_type; - - case FFEBLD_opACCTER: - case FFEBLD_opARRTER: - 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 for ffecom_type_expr" == NULL); - /* Fall through. */ - case FFEBLD_opANY: - return error_mark_node; - } -} - -/* 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). */ - -tree -ffecom_which_entrypoint_decl (void) -{ - assert (ffecom_which_entrypoint_decl_ != NULL_TREE); - - return ffecom_which_entrypoint_decl_; -} - -/* 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. */ - -static void -bison_rule_pushlevel_ (void) -{ - emit_line_note (input_location); - pushlevel (0); - clear_last_expr (); - expand_start_bindings (0); -} - -static tree -bison_rule_compstmt_ (void) -{ - tree t; - int keep = kept_level_p (); - - /* Make the temps go away. */ - if (! keep) - current_binding_level->names = NULL_TREE; - - emit_line_note (input_location); - expand_end_bindings (getdecls (), keep, 0); - t = poplevel (keep, 1, 0); - - return t; -} - -/* 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. If - ATTRS is nonzero, use that for the function's attribute list. */ - -tree -builtin_function (const char *name, tree type, int function_code, - enum built_in_class class, const char *library_name, - tree attrs ATTRIBUTE_UNUSED) -{ - tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - if (library_name) - SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); - make_decl_rtl (decl, NULL); - pushdecl (decl); - DECL_BUILT_IN_CLASS (decl) = class; - 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)); - - 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; - } - } - 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) - { - /* 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); - DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl); - if (TREE_CODE (olddecl) != FUNCTION_DECL) - if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) - { - DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); - DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl); - } - } - - /* Keep the old rtl since we can safely use it. */ - COPY_DECL_RTL (olddecl, newdecl); - - /* Merge the type qualifiers. */ - 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_LOCATION (newdecl) = DECL_SOURCE_LOCATION (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); - - /* Copy the assembler name. */ - COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl); - - if (TREE_CODE (newdecl) == FUNCTION_DECL) - { - DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); - DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); - TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); - TREE_READONLY (newdecl) |= TREE_READONLY (olddecl); - DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl); - DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl); - } - } - /* 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_CLASS (olddecl) = NOT_BUILT_IN; - } - - /* 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_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl); - DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (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); - - memcpy ((char *) olddecl + sizeof (struct tree_common), - (char *) newdecl + 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); - 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; - } - } - - /* 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, - DECL_CONTEXT (decl) == 0, - 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 (TREE_CODE (fndecl) != ERROR_MARK) - { - 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); - - if (TREE_CODE (fndecl) != ERROR_MARK) - { - 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 (); - - /* If this is a nested function, protect the local variables in the stack - above us from being collected while we're compiling this function. */ - if (nested) - ggc_push_context (); - - /* Run the optimizers and output the assembler code for this function. */ - rest_of_compilation (fndecl); - - /* Undo the GC context switch. */ - if (nested) - ggc_pop_context (); - } - - if (TREE_CODE (fndecl) != ERROR_MARK - && !nested - && DECL_SAVED_INSNS (fndecl) == 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. */ - /* 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 const char * -ffe_printable_name (tree decl, int v) -{ - /* Just to keep GCC quiet about the unused variable. - In theory, differing values of V should produce different - output. */ - switch (v) - { - default: - if (TREE_CODE (decl) == ERROR_MARK) - return "erroneous code"; - return IDENTIFIER_POINTER (DECL_NAME (decl)); - } -} - -/* g77's function to print out name of current function that caused - an error. */ - -static void -ffe_print_error_function (diagnostic_context *context __attribute__((unused)), - const char *file) -{ - static ffeglobal last_g = NULL; - static ffesymbol last_s = NULL; - ffeglobal g; - ffesymbol s; - const char *kind; - - if ((ffecom_primary_entry_ == NULL) - || (ffesymbol_global (ffecom_primary_entry_) == NULL)) - { - g = NULL; - s = NULL; - kind = NULL; - } - else - { - g = ffesymbol_global (ffecom_primary_entry_); - if (ffecom_nested_entry_ == NULL) - { - s = ffecom_primary_entry_; - kind = _(ffeinfo_kind_message (ffesymbol_kind (s))); - } - else - { - s = ffecom_nested_entry_; - kind = _("In statement function"); - } - } - - if ((last_g != g) || (last_s != s)) - { - if (file) - fprintf (stderr, "%s: ", file); - - if (s == NULL) - fprintf (stderr, _("Outside of any program unit:\n")); - else - { - const char *name = ffesymbol_text (s); - - fprintf (stderr, "%s `%s':\n", kind, name); - } - - last_g = g; - last_s = s; - } -} - -/* 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 f_binding_level'. */ - -static struct f_binding_level * -make_binding_level (void) -{ - /* NOSTRICT */ - return ggc_alloc (sizeof (struct f_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 f_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 (void) -{ - 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 (current_function_decl != error_mark_node - && 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 (void) -{ - struct f_function *p = 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; - - /* 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 (tree x) -{ - register tree t; - register struct f_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 (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; - - if (fndecl == error_mark_node) - return; - - /* 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); - - /* 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); - - 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_SET_P (tem)) - { - 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); - } - - 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 - ffe_parse_file 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); - } - - if (TREE_CODE (type) == ERROR_MARK) - decl1 = current_function_decl = error_mark_node; - else - { - 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); - current_binding_level->prep_state = 2; - - if (TREE_CODE (current_function_decl) != ERROR_MARK) - { - make_decl_rtl (current_function_decl, NULL); - - restype = TREE_TYPE (TREE_TYPE (current_function_decl)); - DECL_RESULT (current_function_decl) - = build_decl (RESULT_DECL, NULL_TREE, restype); - } - - if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK)) - TREE_ADDRESSABLE (current_function_decl) = 1; - - immediate_size_expand = old_immediate_size_expand; -} - -/* Here are the public functions the GNU back end needs. */ - -tree -convert (tree type, tree 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; -} - -/* 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 (void) -{ - return current_binding_level->names; -} - -/* Nonzero if we are currently in the global binding level. */ - -int -global_bindings_p (void) -{ - return current_binding_level == global_binding_level; -} - -static void -ffecom_init_decl_processing (void) -{ - malloc_init (); - - ffe_init_0 (); -} - -/* Delete the node BLOCK from the current binding level. - This is used for the block inside a stmt expr ({...}) - so that the block can be reinserted where appropriate. */ - -static void -delete_block (tree block) -{ - tree t; - if (current_binding_level->blocks == block) - current_binding_level->blocks = TREE_CHAIN (block); - for (t = current_binding_level->blocks; t;) - { - if (TREE_CHAIN (t) == block) - TREE_CHAIN (t) = TREE_CHAIN (block); - else - t = TREE_CHAIN (t); - } - TREE_CHAIN (block) = NULL; - /* Clear TREE_USED which is always set by poplevel. - The flag is set again if insert_block is called. */ - TREE_USED (block) = 0; -} - -void -insert_block (tree block) -{ - TREE_USED (block) = 1; - current_binding_level->blocks - = chainon (current_binding_level->blocks, block); -} - -/* Each front end provides its own. */ -static bool ffe_init (void); -static void ffe_finish (void); -static bool ffe_post_options (const char **); -static void ffe_print_identifier (FILE *, tree, int); - -struct language_function GTY(()) -{ - int unused; -}; - -#undef LANG_HOOKS_NAME -#define LANG_HOOKS_NAME "GNU F77" -#undef LANG_HOOKS_INIT -#define LANG_HOOKS_INIT ffe_init -#undef LANG_HOOKS_FINISH -#define LANG_HOOKS_FINISH ffe_finish -#undef LANG_HOOKS_INIT_OPTIONS -#define LANG_HOOKS_INIT_OPTIONS ffe_init_options -#undef LANG_HOOKS_HANDLE_OPTION -#define LANG_HOOKS_HANDLE_OPTION ffe_handle_option -#undef LANG_HOOKS_POST_OPTIONS -#define LANG_HOOKS_POST_OPTIONS ffe_post_options -#undef LANG_HOOKS_PARSE_FILE -#define LANG_HOOKS_PARSE_FILE ffe_parse_file -#undef LANG_HOOKS_MARK_ADDRESSABLE -#define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable -#undef LANG_HOOKS_PRINT_IDENTIFIER -#define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier -#undef LANG_HOOKS_DECL_PRINTABLE_NAME -#define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name -#undef LANG_HOOKS_PRINT_ERROR_FUNCTION -#define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function -#undef LANG_HOOKS_TRUTHVALUE_CONVERSION -#define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion - -#undef LANG_HOOKS_TYPE_FOR_MODE -#define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode -#undef LANG_HOOKS_TYPE_FOR_SIZE -#define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size -#undef LANG_HOOKS_SIGNED_TYPE -#define LANG_HOOKS_SIGNED_TYPE ffe_signed_type -#undef LANG_HOOKS_UNSIGNED_TYPE -#define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type -#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE -#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type - -/* We do not wish to use alias-set based aliasing at all. Used in the - extreme (every object with its own set, with equivalences recorded) it - might be helpful, but there are problems when it comes to inlining. We - get on ok with flag_argument_noalias, and alias-set aliasing does - currently limit how stack slots can be reused, which is a lose. */ -#undef LANG_HOOKS_GET_ALIAS_SET -#define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0 - -const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - -/* Table indexed by tree code giving a string containing a character - classifying the tree code. Possibilities are - t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, - -const char tree_code_type[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -/* Table indexed by tree code giving number of expression - operands beyond the fixed part of the node structure. - Not used for types or decls. */ - -#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, - -const unsigned char tree_code_length[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -/* Names of tree components. - Used for printing out the tree and error messages. */ -#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, - -const char *const tree_code_name[] = { -#include "tree.def" -}; -#undef DEFTREECODE - -static bool -ffe_post_options (const char **pfilename) -{ - const char *filename = *pfilename; - - /* Open input file. */ - if (filename == 0 || !strcmp (filename, "-")) - { - finput = stdin; - filename = "stdin"; - } - else - finput = fopen (filename, "r"); - - if (finput == 0) - fatal_error ("can't open %s: %m", filename); - - return false; -} - - -static bool -ffe_init (void) -{ -#ifdef IO_BUFFER_SIZE - setvbuf (finput, xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); -#endif - - ffecom_init_decl_processing (); - - /* 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); - - push_srcloc (input_filename, 0); - - /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to - set the new file name. Maybe in ffe_post_options. */ - return true; -} - -static void -ffe_finish (void) -{ - ffe_terminate_0 (); - - if (ffe_is_ffedebug ()) - malloc_pool_display (malloc_pool_image ()); - - fclose (finput); -} - -static bool -ffe_mark_addressable (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 true; - - 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 false; - } - 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 false; - } - assert ("address of register var requested" == NULL); - } - put_var_into_stack (x, /*rescan=*/true); - - /* 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 true; - } -} - -/* 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 (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. - - DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is - true, since then the decl goes through save_for_inline_copying. */ - if (DECL_ABSTRACT_ORIGIN (decl) != 0 - && DECL_ABSTRACT_ORIGIN (decl) != decl) - TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; - else if (DECL_SAVED_INSNS (decl) != 0) - { - 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; - } - - /* 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 f_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 - && current_function_decl != error_mark_node) - 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); - - if (block) - TREE_USED (block) = 1; - return block; -} - -static void -ffe_print_identifier (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); -} - -/* 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 (tree x) -{ - register tree t; - register tree name = DECL_NAME (x); - register struct f_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)) - { - DECL_ARTIFICIAL (x) = 1; - DECL_IN_SYSTEM_HEADER (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 it 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; -} - -/* Nonzero if the current level needs to have a BLOCK made. */ - -static int -kept_level_p (void) -{ - tree decl; - - for (decl = current_binding_level->names; - decl; - decl = TREE_CHAIN (decl)) - { - if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL - || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl))) - /* Currently, there aren't supposed to be non-artificial names - at other than the top block for a function -- they're - believed to always be temps. But it's wise to check anyway. */ - return 1; - } - return 0; -} - -/* 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 (int tag_transparent) -{ - register struct f_binding_level *newlevel = NULL_BINDING_LEVEL; - - assert (! tag_transparent); - - if (current_binding_level == global_binding_level) - { - named_labels = 0; - } - - /* 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 (tree block) -{ - current_binding_level->this_block = block; - current_binding_level->names = chainon (current_binding_level->names, - BLOCK_VARS (block)); - current_binding_level->blocks = chainon (current_binding_level->blocks, - BLOCK_SUBBLOCKS (block)); -} - -static tree -ffe_signed_or_unsigned_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 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp); - if (type2 == NULL_TREE) - return type; - - return type2; -} - -static tree -ffe_signed_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 = ffe_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'. */ - -static tree -ffe_truthvalue_conversion (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, - ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)), - ffe_truthvalue_conversion (TREE_OPERAND (expr, 1))); - - case NEGATE_EXPR: - case ABS_EXPR: - case FLOAT_EXPR: - /* These don't change whether an object is nonzero or zero. */ - return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case LROTATE_EXPR: - case RROTATE_EXPR: - /* These don't change whether an object is zero or nonzero, 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), - ffe_truthvalue_conversion (TREE_OPERAND (expr, 0))); - else - return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)); - - case COND_EXPR: - { - /* Distribute the conversion into the arms of a COND_EXPR. */ - tree arg1 = TREE_OPERAND (expr, 1); - tree arg2 = TREE_OPERAND (expr, 2); - if (! VOID_TYPE_P (TREE_TYPE (arg1))) - arg1 = ffe_truthvalue_conversion (arg1); - if (! VOID_TYPE_P (TREE_TYPE (arg2))) - arg2 = ffe_truthvalue_conversion (arg2); - return fold (build (COND_EXPR, integer_type_node, - TREE_OPERAND (expr, 0), arg1, arg2)); - } - - 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 ffe_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, - ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR, - TREE_TYPE (TREE_TYPE (expr)), - expr)), - ffe_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)); -} - -static tree -ffe_type_for_mode (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 HOST_BITS_PER_WIDE_INT >= 64 - if (mode == TYPE_MODE (intTI_type_node)) - return unsignedp ? unsigned_intTI_type_node : intTI_type_node; -#endif - - 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 (long_double_type_node)) - return long_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; -} - -static tree -ffe_type_for_size (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; -} - -static tree -ffe_unsigned_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 = ffe_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; -} - -/* 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 const char * -skip_redundant_dir_prefix (const 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; - const char *fname; - /* Mapping of file names for this directory. */ - struct file_name_map *name_map; - /* Nonzero 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 { - const char *fname; - /* Filename specified with #line command. */ - const 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. */ - -/* Current nesting level of input sources. - `instack[indepth]' is the level currently being read. */ -static int indepth = -1; - -typedef struct file_buf FILE_BUF; - -/* 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 *read_filename_string (int ch, FILE *f); -static struct file_name_map *read_name_map (const char *dirname); - -/* 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 (struct file_name_list *first, - struct file_name_list *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 (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 = strrchr (filename, '/'); -#ifdef DIR_SEPARATOR - if (! p) p = strrchr (filename, DIR_SEPARATOR); - else { - char *tmp = strrchr (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 = xmalloc (p - filename + 1); - memcpy (dir, filename, 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; - const char *str1; - const 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 = ""; - - /* xgettext:no-c-format */ - 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 (int ch, FILE *f) -{ - char *alloc, *set; - int len; - - len = 20; - set = alloc = xmalloc (len + 1); - if (! ISSPACE (ch)) - { - *set++ = ch; - while ((ch = getc (f)) != EOF && ! ISSPACE (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 (const 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 = xmalloc (sizeof (struct file_name_map_list)); - map_list_ptr->map_list_name = xstrdup (dirname); - map_list_ptr->map_list_map = NULL; - - dirlen = strlen (dirname); - separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; - if (separator_needed) - name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL); - else - name = concat (dirname, FILE_NAME_MAP_FILE, NULL); - 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 (ISSPACE (ch)) - continue; - from = read_filename_string (ch, f); - while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n') - ; - to = read_filename_string (ch, f); - - ptr = xmalloc (sizeof (struct file_name_map)); - ptr->map_from = from; - - /* Make the real filename absolute. */ - if (*to == '/') - ptr->map_to = to; - else - { - if (separator_needed) - ptr->map_to = concat (dirname, "/", to, NULL); - else - ptr->map_to = concat (dirname, to, NULL); - 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 void -ffecom_file_ (const 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]; - memset (fp, 0, sizeof (FILE_BUF)); - if (name == NULL) - name = ""; - fp->nominal_fname = fp->fname = name; -} - -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); -} - -void -ffecom_decode_include_option (const char *dir) -{ - if (! ignore_srcdir && !strcmp (dir, "-")) - ignore_srcdir = 1; - else - { - struct file_name_list *dirtmp - = xmalloc (sizeof (struct file_name_list)); - dirtmp->next = 0; /* New one goes on the end */ - dirtmp->fname = dir; - dirtmp->got_name_map = 0; - append_include_chain (dirtmp, dirtmp); - } -} - -/* 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; - const 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 = strrchr (nam, '/'); -#ifdef DIR_SEPARATOR - if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR); - else { - char *tmp = strrchr (nam, DIR_SEPARATOR); - if (tmp != NULL && tmp > ep) ep = tmp; - } -#endif -#else /* VMS */ - ep = strrchr (nam, ']'); - if (ep == NULL) ep = strrchr (nam, '>'); - if (ep == NULL) ep = strrchr (nam, ':'); - if (ep != NULL) ep++; -#endif /* VMS */ - if (ep != NULL) - { - n = ep - nam; - fname = xmalloc (n + 1); - strncpy (fname, nam, n); - fname[n] = '\0'; - dsp[0].fname = fname; - 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); - } - 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 (strchr (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); - /* xgettext:no-c-format */ - 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 ((char *) dsp[0].fname); - - if (f == NULL) - return NULL; - - if (indepth >= (INPUT_STACK_MAX - 1)) - { - print_containing_files (FFEBAD_severityFATAL); - /* xgettext:no-c-format */ - 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]; - memset (fp, 0, sizeof (FILE_BUF)); - fp->nominal_fname = fp->fname = fname; - fp->dir = searchptr; - - indepth++; - input_file_stack_tick++; - - return f; -} - -/**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.) // - - - - - - - - - - - - - - - - - - - - - - - -// 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) - -*/ - -#include "gt-f-com.h" -#include "gtype-f.h" |
