#include "proj.h"
#include "flags.h"
#include "real.h"
#include "rtl.h"
#include "toplev.h"
#include "tree.h"
#include "output.h"
#include "convert.h"
#include "ggc.h"
#include "diagnostic.h"
#include "intl.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include "debug.h"
#ifdef VMS
#include <descrip.h>
#define O_RDONLY 0
#define O_WRONLY 1
#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
#endif
#define FFECOM_DETERMINE_TYPES 1
#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"
FILE *finput;
tree string_type_node;
static GTY(()) tree ffecom_tree_fun_type_void;
tree ffecom_integer_type_node;
tree ffecom_integer_zero_node;
tree ffecom_integer_one_node;
tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
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;
#ifndef FFECOM_sizeMAXSTACKITEM
#define FFECOM_sizeMAXSTACKITEM 32*1024
#endif
#if FFECOM_sizeMAXSTACKITEM == 0
#undef FFECOM_sizeMAXSTACKITEM
#endif
typedef enum
{
FFECOM_rttypeVOID_,
FFECOM_rttypeVOIDSTAR_,
FFECOM_rttypeFTNINT_,
FFECOM_rttypeINTEGER_,
FFECOM_rttypeLONGINT_,
FFECOM_rttypeLOGICAL_,
FFECOM_rttypeREAL_F2C_,
FFECOM_rttypeREAL_GNU_,
FFECOM_rttypeCOMPLEX_F2C_,
FFECOM_rttypeCOMPLEX_GNU_,
FFECOM_rttypeDOUBLE_,
FFECOM_rttypeDOUBLEREAL_,
FFECOM_rttypeDBLCMPLX_F2C_,
FFECOM_rttypeDBLCMPLX_GNU_,
FFECOM_rttypeCHARACTER_,
FFECOM_rttype_
} ffecomRttype_;
typedef struct _ffecom_concat_list_ ffecomConcatList_;
struct _ffecom_concat_list_
{
ffebld *exprs;
int count;
int max;
ffetargetCharacterSize minlen;
ffetargetCharacterSize maxlen;
};
static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
static tree ffe_type_for_size PARAMS ((unsigned int, int));
static tree ffe_unsigned_type PARAMS ((tree));
static tree ffe_signed_type PARAMS ((tree));
static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
static bool ffe_mark_addressable PARAMS ((tree));
static tree ffe_truthvalue_conversion PARAMS ((tree));
static void ffecom_init_decl_processing PARAMS ((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);
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 int ffecom_decode_include_option_ (char *spec);
static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
ffewhereColumn c);
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_;
static GTY(()) tree ffecom_func_length_;
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_;
static bool ffecom_doing_entry_ = FALSE;
static bool ffecom_transform_only_dummies_ = FALSE;
static int ffecom_typesize_pointer_;
static int ffecom_typesize_integer1_;
static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
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
};
static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
#include "com-rt.def"
#undef DEFGFRT
};
static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
#include "com-rt.def"
#undef DEFGFRT
};
static const bool ffecom_gfrt_const_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
#include "com-rt.def"
#undef DEFGFRT
};
static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
#include "com-rt.def"
#undef DEFGFRT
};
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
};
#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)
struct f_binding_level GTY(())
{
tree names;
tree blocks;
tree this_block;
struct f_binding_level *level_chain;
int prep_state;
};
#define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
static GTY(()) struct f_binding_level *current_binding_level;
static GTY((deletable (""))) struct f_binding_level *free_binding_level;
static struct f_binding_level *global_binding_level;
static const struct f_binding_level clear_binding_level
=
{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
struct lang_identifier GTY(())
{
struct tree_identifier common;
tree global_value;
tree local_value;
tree label_value;
bool invented;
};
#define IDENTIFIER_GLOBAL_VALUE(NODE) \
(((struct lang_identifier *)(NODE))->global_value)
#define IDENTIFIER_LOCAL_VALUE(NODE) \
(((struct lang_identifier *)(NODE))->local_value)
#define IDENTIFIER_LABEL_VALUE(NODE) \
(((struct lang_identifier *)(NODE))->label_value)
#define IDENTIFIER_INVENTED(NODE) \
(((struct lang_identifier *)(NODE))->invented)
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;
};
struct lang_decl GTY(())
{
};
struct lang_type GTY(())
{
};
static GTY(()) tree named_labels;
static GTY(()) tree shadowed_labels;
int
comptypes (type1, type2)
tree type1, type2;
{
register tree t1 = type1;
register tree t2 = type2;
if (t1 == t2 || !t1 || !t2
|| TREE_CODE (t1) == ERROR_MARK || TREE_CODE (t2) == ERROR_MARK)
return 1;
return 0;
}
tree
default_conversion (exp)
tree exp;
{
return exp;
}
tree
lang_build_type_variant (type, constp, volatilep)
tree type;
int constp, volatilep;
{
return type;
}
static tree
ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
const char *array_name)
{
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)
{
if (dim)
cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
else
cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
}
else
{
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));
}
}
{
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);
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 (lineno, 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);
element = ffecom_3 (COND_EXPR,
TREE_TYPE (element),
cond,
element,
die);
return element;
}
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?]";
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_)
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);
if (element == error_mark_node)
return element;
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);
if (element == error_mark_node)
return element;
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;
}
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:
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;
}
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));
}
static tree
ffecom_convert_narrow_ (type, expr)
tree type, expr;
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
if (type == TREE_TYPE (e)
|| TREE_CODE (e) == ERROR_MARK)
return e;
if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
return fold (build1 (NOP_EXPR, type, e));
if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
|| code == ERROR_MARK)
return error_mark_node;
if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
{
assert ("void value not ignored as it ought to be" == NULL);
return error_mark_node;
}
assert (code != VOID_TYPE);
if ((code != RECORD_TYPE)
&& (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
assert ("converting COMPLEX to REAL" == NULL);
assert (code != ENUMERAL_TYPE);
if (code == INTEGER_TYPE)
{
assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
&& 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);
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;
}
static tree
ffecom_convert_widen_ (type, expr)
tree type, expr;
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
if (type == TREE_TYPE (e)
|| TREE_CODE (e) == ERROR_MARK)
return e;
if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
return fold (build1 (NOP_EXPR, type, e));
if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
|| code == ERROR_MARK)
return error_mark_node;
if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
{
assert ("void value not ignored as it ought to be" == NULL);
return error_mark_node;
}
assert (code != VOID_TYPE);
if ((code != RECORD_TYPE)
&& (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
assert ("narrowing COMPLEX to REAL" == NULL);
assert (code != ENUMERAL_TYPE);
if (code == INTEGER_TYPE)
{
assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
&& 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);
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;
}
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;
}
static tree
ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
{
tree bothparts;
if (ffe_is_emulate_complex ())
{
bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
}
else
{
bothparts = build_complex (type, realpart, imagpart);
}
return bothparts;
}
static tree
ffecom_arglist_expr_ (const char *c, ffebld expr)
{
tree list;
tree *plist = &list;
tree trail = NULL_TREE;
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);
}
}
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;
}
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;
return TRUE;
}
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 FFS_EXPR:
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case LROTATE_EXPR:
case RROTATE_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
case BIT_AND_EXPR:
case BIT_ANDTC_EXPR:
case BIT_NOT_EXPR:
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
case TRUTH_NOT_EXPR:
case LT_EXPR:
case LE_EXPR:
case GT_EXPR:
case GE_EXPR:
case EQ_EXPR:
case NE_EXPR:
case COMPLEX_EXPR:
case CONJ_EXPR:
case REALPART_EXPR:
case IMAGPART_EXPR:
case LABEL_EXPR:
case COMPONENT_REF:
return FALSE;
case COMPOUND_EXPR:
return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
TREE_OPERAND (source_tree, 1), NULL,
scalar_arg);
case MODIFY_EXPR:
return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
TREE_OPERAND (source_tree, 0), NULL,
scalar_arg);
case CONVERT_EXPR:
case NOP_EXPR:
case NON_LVALUE_EXPR:
case PLUS_EXPR:
if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
return TRUE;
ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
source_tree);
source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
break;
case COND_EXPR:
return
ffecom_overlap_ (dest_decl, dest_offset, dest_size,
TREE_OPERAND (source_tree, 1), NULL,
scalar_arg)
|| ffecom_overlap_ (dest_decl, dest_offset, dest_size,
TREE_OPERAND (source_tree, 2), NULL,
scalar_arg);
case ADDR_EXPR:
ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
&source_size,
TREE_OPERAND (source_tree, 0));
break;
case PARM_DECL:
if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
return TRUE;
source_decl = source_tree;
source_offset = 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;
}
if (source_decl == NULL_TREE)
return FALSE;
if (source_decl != dest_decl)
return FALSE;
if (TREE_CODE (dest_size) == ERROR_MARK)
return TRUE;
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;
if (!scalar_arg
|| (source_size == NULL_TREE)
|| (TREE_CODE (source_size) == ERROR_MARK)
|| integer_zerop (source_size))
return TRUE;
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;
return TRUE;
}
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;
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;
}
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;
}
}
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;
}
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)
{
left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
}
else
{
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);
}
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)
{
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));
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
*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);
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)));
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);
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);
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);
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)
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)
{
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)
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))))
{
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
{
*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;
}
static tree
ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
{
if (TREE_CODE (type) == ERROR_MARK)
return type;
if (TYPE_SIZE (type) == NULL_TREE)
return type;
if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
return type;
if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
|| (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 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;
}
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;
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;
}
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;
switch (ffebld_op (expr))
{
case FFEBLD_opCONTER:
case FFEBLD_opSYMTER:
case FFEBLD_opARRAYREF:
case FFEBLD_opFUNCREF:
case FFEBLD_opSUBSTR:
case FFEBLD_opCONVERT:
if (catlist.count == catlist.max)
{
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;
if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
catlist.maxlen = sz;
else
catlist.maxlen += sz;
if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
{
switch (ffebld_op (expr))
{
case FFEBLD_opCONTER:
case FFEBLD_opSYMTER:
case FFEBLD_opARRAYREF:
case FFEBLD_opFUNCREF:
case FFEBLD_opSUBSTR:
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
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;
}
}
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]));
}
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);
}
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;
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;
decl = start_decl (decl, FALSE);
finish_decl (decl, value, FALSE);
if (buff != &space[0])
malloc_kill_ks (malloc_pool_image (), buff, len + 1);
}
static void
ffecom_do_entry_ (ffesymbol fn, int entrynum)
{
ffebld item;
tree type;
tree multi_retval;
tree result;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
ffeglobalType gt;
bool charfunc;
bool cmplxfunc;
bool multi;
bool altreturning = FALSE;
int old_lineno = lineno;
const char *old_input_filename = input_filename;
input_filename = ffesymbol_where_filename (fn);
lineno = ffesymbol_where_filelinenum (fn);
ffecom_doing_entry_ = TRUE;
switch (ffecom_primary_entry_kind_)
{
case FFEINFO_kindFUNCTION:
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;
multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
break;
case FFEINFO_kindSUBROUTINE:
gt = FFEGLOBAL_typeSUBR;
bt = FFEINFO_basictypeNONE;
kt = FFEINFO_kindtypeNONE;
if (ffecom_is_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);
case FFEINFO_kindANY:
gt = FFEGLOBAL_typeANY;
bt = FFEINFO_basictypeNONE;
kt = FFEINFO_kindtypeNONE;
type = error_mark_node;
charfunc = FALSE;
cmplxfunc = FALSE;
multi = FALSE;
break;
}
start_function (ffecom_get_external_identifier_ (fn),
type,
0,
1);
if (((g = ffesymbol_global (fn)) != NULL)
&& ((ffeglobal_type (g) == gt)
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
{
ffeglobal_set_hook (g, current_function_decl);
}
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;
s = ffebld_symter (arg);
ffesymbol_hook (s).decl_tree = NULL_TREE;
ffesymbol_hook (s).length_tree = NULL_TREE;
}
if (charfunc || cmplxfunc)
{
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");
if (charfunc)
length = ffecom_char_enhance_arg_ (&type, fn);
else
length = NULL_TREE;
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 ();
current_binding_level->prep_state = 2;
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;
{
ffebld list;
ffebld arg;
ffesymbol s;
tree arglist = NULL_TREE;
tree *plist = &arglist;
tree prepend;
tree call;
tree actarg;
tree master_fn;
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;
else
actarg = ffesymbol_hook (s).decl_tree;
*plist = build_tree_list (NULL_TREE, actarg);
plist = &TREE_CHAIN (*plist);
}
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;
if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
continue;
if (ffesymbol_hook (s).length_tree == NULL_TREE
|| ffesymbol_hook (s).length_tree == error_mark_node)
actarg = ffecom_f2c_ftnlen_zero_node;
else
actarg = ffesymbol_hook (s).length_tree;
*plist = build_tree_list (NULL_TREE, actarg);
plist = &TREE_CHAIN (*plist);
}
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;
}
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 = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
TREE_CHAIN (prepend) = arglist;
arglist = prepend;
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);
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);
lineno = old_lineno;
input_filename = old_input_filename;
ffecom_doing_entry_ = FALSE;
}
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;
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];
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, NULL_TREE, 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);
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)
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, NULL_TREE, 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);
s = ffebld_symter (expr);
t = ffesymbol_hook (s).decl_tree;
if (assignp)
{
if (ffe_is_ugly_assign ())
{
if (t == NULL_TREE)
{
s = ffecom_sym_transform_ (s);
t = ffesymbol_hook (s).decl_tree;
assert (t != NULL_TREE);
}
if (t == error_mark_node)
return t;
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
>= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
{
if (ffesymbol_hook (s).addr)
t = ffecom_1 (INDIRECT_REF,
TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
return t;
}
if (ffesymbol_hook (s).assign_tree == NULL_TREE)
{
ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
FFEBAD_severityWARNING);
ffebad_string (ffesymbol_text (s));
ffebad_here (0, ffesymbol_where_line (s),
ffesymbol_where_column (s));
ffebad_finish ();
}
}
if (t != NULL_TREE
&& TREE_CODE (t) == VAR_DECL)
DECL_IN_SYSTEM_HEADER (t) = 1;
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:
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;
ltkt = FFEINFO_kindtypeREAL1;
}
else
{
code = FFECOM_gfrtPOW_ZI;
ltkt = FFEINFO_kindtypeREAL2;
}
break;
default:
assert ("bad pow_*i" == NULL);
code = FFECOM_gfrtPOW_CI;
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);
code = FFECOM_gfrtL_POW;
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;
ref = TRUE;
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);
case FFEINFO_basictypeANY:
return error_mark_node;
}
break;
case FFEBLD_opFUNCREF:
assert (ffeinfo_basictype (ffebld_info (expr))
!= FFEINFO_basictypeCHARACTER);
case FFEBLD_opSUBRREF:
if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
== FFEINFO_whereINTRINSIC)
{
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);
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);
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);
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);
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;
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);
case FFEINFO_basictypeANY:
return error_mark_node;
}
break;
default:
assert ("CONVERT bad basictype" == NULL);
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;
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);
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);
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
}
static tree
ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
ffebld dest, bool *dest_used)
{
tree expr_tree;
tree saved_expr1;
tree saved_expr2;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
tree tree_type;
tree arg1_type;
tree real_type;
tree tempvar;
ffebld list = ffebld_right (expr);
ffebld arg1;
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;
if (arg1 != NULL)
arg1_type = ffecom_tree_type
[ffeinfo_basictype (ffebld_info (arg1))]
[ffeinfo_kindtype (ffebld_info (arg1))];
else
arg1_type = NULL_TREE;
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
return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
#else
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
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
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;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtCDCOS;
}
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;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtCDEXP;
}
break;
case FFEINTRIN_impICHAR:
case FFEINTRIN_impIACHAR:
#if 0
ffecom_char_args_ (&expr_tree, &saved_expr1 , 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
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;
#else
return ffecom_intrinsic_len_ (arg1);
#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;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtCDLOG;
}
break;
case FFEINTRIN_impLOG10:
case FFEINTRIN_impALOG10:
case FFEINTRIN_impDLOG10:
if (gfrt != FFECOM_gfrt)
break;
if (kt == FFEINFO_kindtypeREAL1)
gfrt = FFECOM_gfrtL_LOG10;
else if (kt == FFEINFO_kindtypeREAL2)
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)
gfrt = FFECOM_gfrtL_FMOD;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtL_FMOD;
break;
case FFEINTRIN_impNINT:
case FFEINTRIN_impIDNINT:
#if 0
return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
#else
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));
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;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtCDSIN;
}
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;
else if (kt == FFEINFO_kindtypeREAL2)
gfrt = FFECOM_gfrtCDSQRT;
}
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))));
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))));
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));
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);
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);
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);
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);
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);
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:
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);
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);
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:
{
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;
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:
case FFEINTRIN_impFDATE_func:
case FFEINTRIN_impTTYNAM_func:
case FFEINTRIN_impNONE:
case FFEINTRIN_imp:
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);
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));
}
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))
{
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);
}
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)
{
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;
}
if (ffecom_transform_only_dummies_)
return NULL_TREE;
{
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 (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 (NULL_TREE);
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 (NULL_TREE);
expand_end_cond (NULL_TREE);
expand_start_loop (1, NULL_TREE);
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 (NULL_TREE);
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 (NULL_TREE);
if (!integer_zerop (basetypeof_l_is_int))
expand_end_cond (NULL_TREE);
expand_expr_stmt (result);
t = ffecom_end_compstmt ();
result = expand_end_stmt_expr (se);
if (TREE_CODE (t) == BLOCK)
{
result = build (BIND_EXPR, TREE_TYPE (result),
NULL_TREE, result, t);
delete_block (t);
}
else
result = t;
}
return result;
}
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;
}
break;
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;
}
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));
}
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;
}
}
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;
DECL_EXTERNAL (cbt) = 0;
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;
}
static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s)
{
if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
return s;
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))
s = ffecom_sym_transform_ (s);
}
if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
&& (ffesymbol_hook (s).decl_tree != error_mark_node))
{
ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
ffesymbol_storage (s));
}
return s;
}
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;
}
static tree
ffecom_get_external_identifier_ (ffesymbol s)
{
char us;
const char *name = ffesymbol_text (s);
if (!ffe_is_underscoring ()
|| (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
#if FFETARGET_isENFORCED_MAIN_NAME
|| (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
#else
|| (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
#endif
|| (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
return get_identifier (name);
us = ffe_is_second_underscore ()
? (strchr (name, '_') != NULL)
: 0;
return ffecom_get_appended_identifier_ (us, name);
}
static tree
ffecom_get_identifier_ (const char *name)
{
if (!ffe_is_underscoring ()
|| (strchr (name, '_') == NULL))
return get_identifier (name);
return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
name);
}
static tree
ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
{
ffebld expr = ffesymbol_sfexpr (s);
tree type;
tree func;
tree result;
bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
static bool recurse = FALSE;
int old_lineno = lineno;
const char *old_input_filename = input_filename;
ffecom_nested_entry_ = s;
input_filename = ffesymbol_where_filename (s);
lineno = ffesymbol_where_filelinenum (s);
ffecom_expr_transform_ (expr);
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;
}
start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
build_function_type (type, NULL_TREE),
1,
0);
if (charfunc)
{
tree type;
type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
result = ffecom_get_invented_identifier ("__g77_%s", "result");
ffecom_char_enhance_arg_ (&type, s);
type = build_pointer_type (type);
result = build_decl (PARM_DECL, result, type);
push_parm_decl (result);
}
else
result = NULL_TREE;
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;
lineno = old_lineno;
input_filename = old_input_filename;
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]);
}
#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;
}
{
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, 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:
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
*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;
}
}
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
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;
}
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);
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:
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:
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:
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 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);
}
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);
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;
assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
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;
}
static void
ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
{
ffesymbol s = ffestorag_symbol (st);
if (ffesymbol_namelisted (s))
ffecom_member_namelisted_ = TRUE;
}
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);
}
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;
}
}
static void
ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
{
ffebld dummy;
ffebld dumlist;
ffesymbol s;
tree parm;
ffecom_transform_only_dummies_ = TRUE;
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;
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);
}
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;
default:
break;
}
s = ffebld_symter (dummy);
if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
continue;
if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
continue;
if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
continue;
parm = ffesymbol_hook (s).length_tree;
assert (parm != NULL_TREE);
if (parm != error_mark_node)
push_parm_decl (parm);
}
ffecom_transform_only_dummies_ = FALSE;
}
static void
ffecom_start_progunit_ ()
{
ffesymbol fn = ffecom_primary_entry_;
ffebld arglist;
tree id;
tree type;
tree result;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
ffeglobalType gt;
ffeglobalType egt = FFEGLOBAL_type;
bool charfunc;
bool cmplxfunc;
bool altentries = (ffecom_num_entrypoints_ != 0);
bool multi
= altentries
&& (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
&& (ffecom_master_bt_ == FFEINFO_basictypeNONE);
bool main_program = FALSE;
int old_lineno = lineno;
const char *old_input_filename = input_filename;
assert (fn != NULL);
assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
input_filename = ffesymbol_where_filename (fn);
lineno = 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;
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);
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,
!altentries);
TREE_USED (current_function_decl) = 1;
if (!altentries
&& ((g = ffesymbol_global (fn)) != NULL)
&& ((ffeglobal_type (g) == gt)
|| (ffeglobal_type (g) == egt)))
{
ffeglobal_set_hook (g, current_function_decl);
}
if (altentries)
{
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)
{
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");
if (charfunc)
length = ffecom_char_enhance_arg_ (&type, fn);
else
length = NULL_TREE;
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 ();
current_binding_level->prep_state = 2;
lineno = old_lineno;
input_filename = old_input_filename;
if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
ffesymbol_drive (ffecom_finish_symbol_transform_);
}
static ffesymbol
ffecom_sym_transform_ (ffesymbol s)
{
tree t;
tree tlen;
bool addr;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
int old_lineno = lineno;
const char *old_input_filename = input_filename;
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);
lineno = ffesymbol_where_filelinenum (s);
}
else
{
ffesymbol sf = ffesymbol_sfdummyparent (s);
input_filename = ffesymbol_where_filename (sf);
lineno = ffesymbol_where_filelinenum (sf);
}
bt = ffeinfo_basictype (ffebld_info (s));
kt = ffeinfo_kindtype (ffebld_info (s));
t = NULL_TREE;
tlen = NULL_TREE;
addr = FALSE;
switch (ffesymbol_kind (s))
{
case FFEINFO_kindNONE:
switch (ffesymbol_where (s))
{
case FFEINFO_whereDUMMY:
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_whereGLOBAL:
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);
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);
case FFEINFO_whereANY:
break;
}
break;
case FFEINFO_kindENTITY:
switch (ffeinfo_where (ffesymbol_info (s)))
{
case FFEINFO_whereCONSTANT:
assert (!ffecom_transform_only_dummies_);
t = error_mark_node;
break;
case FFEINFO_whereLOCAL:
assert (!ffecom_transform_only_dummies_);
{
ffestorag st = ffesymbol_storage (s);
tree type;
if ((st != NULL)
&& (ffestorag_size (st) == 0))
{
t = error_mark_node;
break;
}
type = ffecom_type_localvar_ (s, bt, kt);
if (type == error_mark_node)
{
t = error_mark_node;
break;
}
if ((st != NULL)
&& (ffestorag_parent (st) != NULL))
{
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);
offset = ffestorag_modulo (est)
+ ffestorag_offset (ffesymbol_storage (s))
- ffestorag_offset (est);
ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
t = convert (string_type_node,
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;
if (init || ffe_is_init_local_zero ())
DECL_INITIAL (t) = error_mark_node;
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;
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)
{
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_)))
{
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;
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;
type = ffecom_tree_type[bt][kt];
if (ffesymbol_sfdummyparent (s) != NULL)
{
if (current_function_decl == ffecom_outer_function_decl_)
{
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_)
{
high = NULL;
}
else
high = ffecom_expr (ffebld_right (dim));
if (!adjustable
&& ((TREE_CODE (low) != INTEGER_CST)
|| (high && TREE_CODE (high) != INTEGER_CST)))
adjustable = TRUE;
#if 0
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
if (TREE_CODE (low) != INTEGER_CST)
low = variable_size (low);
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 (ffesymbol_numentries (s)
== (ffecom_num_entrypoints_ + 1))
break;
#if 1
{
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);
if (st != NULL)
{
ffecom_transform_common_ (cs);
st = ffesymbol_storage (s);
}
type = ffecom_type_localvar_ (s, bt, kt);
cg = ffesymbol_global (cs);
if ((cg == NULL)
|| (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
ct = NULL_TREE;
else
ct = ffeglobal_hook (cg);
if ((ct == NULL_TREE)
|| (st == NULL)
|| (type == error_mark_node))
t = error_mark_node;
else
{
ffetargetOffset offset;
ffestorag cst;
cst = ffestorag_parent (st);
assert (cst == ffesymbol_storage (cs));
offset = ffestorag_modulo (cst)
+ ffestorag_offset (st)
- ffestorag_offset (cst);
ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
t = convert (string_type_node,
ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (ct)),
ct));
t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
t,
build_int_2 (offset, 0));
t = convert (build_pointer_type (type),
t);
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);
case FFEINFO_whereANY:
t = error_mark_node;
break;
}
break;
case FFEINFO_kindFUNCTION:
switch (ffeinfo_where (ffesymbol_info (s)))
{
case FFEINFO_whereLOCAL:
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:
assert (!ffecom_transform_only_dummies_);
t = ffecom_gen_sfuncdef_ (s, bt, kt);
break;
case FFEINFO_whereINTRINSIC:
assert (!ffecom_transform_only_dummies_);
break;
default:
assert ("FUNCTION where unheard of" == NULL);
case FFEINFO_whereANY:
t = error_mark_node;
break;
}
break;
case FFEINFO_kindSUBROUTINE:
switch (ffeinfo_where (ffesymbol_info (s)))
{
case FFEINFO_whereLOCAL:
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, FALSE);
finish_decl (t, NULL_TREE, FALSE);
if ((g != NULL)
&& ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
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;
default:
assert ("SUBROUTINE where unheard of" == NULL);
case FFEINFO_whereANY:
t = error_mark_node;
break;
}
break;
case FFEINFO_kindPROGRAM:
switch (ffeinfo_where (ffesymbol_info (s)))
{
case FFEINFO_whereLOCAL:
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);
case FFEINFO_whereANY:
t = error_mark_node;
break;
}
break;
case FFEINFO_kindBLOCKDATA:
switch (ffeinfo_where (ffesymbol_info (s)))
{
case FFEINFO_whereLOCAL:
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);
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);
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);
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);
case FFEINFO_whereANY:
t = error_mark_node;
break;
}
break;
default:
assert ("kind unheard of" == NULL);
case FFEINFO_kindANY:
t = error_mark_node;
break;
}
ffesymbol_hook (s).decl_tree = t;
ffesymbol_hook (s).length_tree = tlen;
ffesymbol_hook (s).addr = addr;
lineno = old_lineno;
input_filename = old_input_filename;
return s;
}
static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s)
{
tree t;
int old_lineno = lineno;
const char *old_input_filename = input_filename;
if (ffesymbol_sfdummyparent (s) == NULL)
{
input_filename = ffesymbol_where_filename (s);
lineno = ffesymbol_where_filelinenum (s);
}
else
{
ffesymbol sf = ffesymbol_sfdummyparent (s);
input_filename = ffesymbol_where_filename (sf);
lineno = ffesymbol_where_filelinenum (sf);
}
assert (!ffecom_transform_only_dummies_);
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:
if ((ffesymbol_is_save (s) || ffe_is_saveall ())
&& (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
&& (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
TREE_STATIC (t) = 1;
else
TREE_STATIC (t) = 0;
break;
case FFEINFO_whereCOMMON:
TREE_STATIC (t) = 1;
break;
case FFEINFO_whereDUMMY:
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;
lineno = old_lineno;
input_filename = old_input_filename;
return s;
}
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;
ffeglobal_size_common (s, ffestorag_size (st));
if (!ffeglobal_common_init (g))
is_init = FALSE;
cbt = ffeglobal_hook (g);
if ((cbt != NULL_TREE)
&& (!is_init
|| !DECL_EXTERNAL (cbt)))
{
if (st->hook == NULL) ffestorag_set_hook (st, cbt);
return;
}
if (is_init)
{
if (ffestorag_init (st) != NULL)
{
ffebld sexp;
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)
{
init = NULL_TREE;
if (cbt != NULL_TREE)
return;
}
}
else
init = error_mark_node;
}
else
init = NULL_TREE;
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));
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);
}
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;
if (is_init)
{
if (ffestorag_init (eqst) != NULL)
{
ffebld sexp;
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;
}
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;
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);
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);
}
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);
i = strlen (ffesymbol_text (s));
high = build_int_2 (i, 0);
TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
nameinit = ffecom_build_f2c_string_ (i + 1,
ffesymbol_text (s));
TREE_TYPE (nameinit)
= build_type_variant
(build_array_type
(char_type_node,
build_range_type (ffecom_f2c_ftnlen_type_node,
ffecom_f2c_ftnlen_one_node,
high)),
1, 0);
TREE_CONSTANT (nameinit) = 1;
TREE_STATIC (nameinit) = 1;
nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
nameinit);
varsinit = ffecom_vardesc_array_ (s);
varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
varsinit);
TREE_CONSTANT (varsinit) = 1;
TREE_STATIC (varsinit) = 1;
{
ffebld b;
for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
++i;
}
nvarsinit = build_int_2 (i, 0);
TREE_TYPE (nvarsinit) = integer_type_node;
TREE_CONSTANT (nvarsinit) = 1;
TREE_STATIC (nvarsinit) = 1;
nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
varsinit);
TREE_CHAIN (TREE_CHAIN (nmlinits))
= build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
TREE_CONSTANT (nmlinits) = 1;
TREE_STATIC (nmlinits) = 1;
finish_decl (nmlt, nmlinits, FALSE);
nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
return nmlt;
}
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)
{
*offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
*offset, TREE_OPERAND (t, 1)));
*offset = size_binop (MULT_EXPR,
convert (bitsizetype, *offset),
TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
break;
}
*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)
{
*decl = TREE_OPERAND (t, 0);
*offset = bitsize_zero_node;
break;
}
default:
*decl = error_mark_node;
break;
}
}
static void
ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
tree *size, tree t)
{
*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 FFS_EXPR:
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case LROTATE_EXPR:
case RROTATE_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
case BIT_AND_EXPR:
case BIT_ANDTC_EXPR:
case BIT_NOT_EXPR:
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
case TRUTH_NOT_EXPR:
case LT_EXPR:
case LE_EXPR:
case GT_EXPR:
case GE_EXPR:
case EQ_EXPR:
case NE_EXPR:
case COMPLEX_EXPR:
case CONJ_EXPR:
case REALPART_EXPR:
case IMAGPART_EXPR:
case LABEL_EXPR:
case COMPONENT_REF:
case COMPOUND_EXPR:
case ADDR_EXPR:
return;
case VAR_DECL:
case PARM_DECL:
*decl = t;
*offset = 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;
*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:
*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:
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;
}
}
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;
else
ix = FFECOM_gfrtDIV_ZZ;
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;
else
ix = FFECOM_gfrtDIV_ZZ;
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);
}
}
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;
}
static GTY(()) tree ffecom_type_namelist_var;
static tree
ffecom_type_namelist_ ()
{
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;
}
static GTY(()) tree ffecom_type_vardesc_var;
static tree
ffecom_type_vardesc_ ()
{
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);
nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
+ 1,
ffesymbol_text (s));
TREE_TYPE (nameinit)
= build_type_variant
(build_array_type
(char_type_node,
build_range_type (integer_type_node,
integer_one_node,
build_int_2 (i, 0))),
1, 0);
TREE_CONSTANT (nameinit) = 1;
TREE_STATIC (nameinit) = 1;
nameinit = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (nameinit)),
nameinit);
addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
dimsinit = ffecom_vardesc_dims_ (s);
if (typeinit == NULL_TREE)
{
ffeinfoBasictype bt = ffesymbol_basictype (s);
ffeinfoKindtype kt = ffesymbol_kindtype (s);
int tc = ffecom_f2c_typecode (bt, kt);
assert (tc != -1);
typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
}
else
typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
nameinit);
TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
addrinit);
TREE_CHAIN (TREE_CHAIN (varinits))
= build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
= build_tree_list ((field = TREE_CHAIN (field)), typeinit);
varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
TREE_CONSTANT (varinits) = 1;
TREE_STATIC (varinits) = 1;
finish_decl (var, varinits, FALSE);
var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
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, NULL_TREE, 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));
}
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, NULL_TREE, 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;
}
}
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);
}
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);
}
tree
ffecom_2 (enum tree_code code, tree type, tree node1,
tree node2)
{
tree item;
if ((node1 == error_mark_node)
|| (node2 == error_mark_node)
|| (type == error_mark_node))
return error_mark_node;
switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
{
tree a, b, c, d, realtype;
case CONJ_EXPR:
assert ("no CONJ_EXPR support yet" == NULL);
return error_mark_node;
case COMPLEX_EXPR:
item = build_tree_list (TYPE_FIELDS (type), node1);
TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
item = build (CONSTRUCTOR, type, NULL_TREE, item);
break;
case PLUS_EXPR:
if (TREE_CODE (type) != RECORD_TYPE)
{
item = build (code, type, node1, node2);
break;
}
node1 = ffecom_stabilize_aggregate_ (node1);
node2 = ffecom_stabilize_aggregate_ (node2);
realtype = TREE_TYPE (TYPE_FIELDS (type));
item =
ffecom_2 (COMPLEX_EXPR, type,
ffecom_2 (PLUS_EXPR, realtype,
ffecom_1 (REALPART_EXPR, realtype,
node1),
ffecom_1 (REALPART_EXPR, realtype,
node2)),
ffecom_2 (PLUS_EXPR, realtype,
ffecom_1 (IMAGPART_EXPR, realtype,
node1),
ffecom_1 (IMAGPART_EXPR, realtype,
node2)));
break;
case MINUS_EXPR:
if (TREE_CODE (type) != RECORD_TYPE)
{
item = build (code, type, node1, node2);
break;
}
node1 = ffecom_stabilize_aggregate_ (node1);
node2 = ffecom_stabilize_aggregate_ (node2);
realtype = TREE_TYPE (TYPE_FIELDS (type));
item =
ffecom_2 (COMPLEX_EXPR, type,
ffecom_2 (MINUS_EXPR, realtype,
ffecom_1 (REALPART_EXPR, realtype,
node1),
ffecom_1 (REALPART_EXPR, realtype,
node2)),
ffecom_2 (MINUS_EXPR, realtype,
ffecom_1 (IMAGPART_EXPR, realtype,
node1),
ffecom_1 (IMAGPART_EXPR, realtype,
node2)));
break;
case MULT_EXPR:
if (TREE_CODE (type) != RECORD_TYPE)
{
item = build (code, type, node1, node2);
break;
}
node1 = ffecom_stabilize_aggregate_ (node1);
node2 = ffecom_stabilize_aggregate_ (node2);
realtype = TREE_TYPE (TYPE_FIELDS (type));
a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
node1));
b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
node1));
c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
node2));
d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
node2));
item =
ffecom_2 (COMPLEX_EXPR, type,
ffecom_2 (MINUS_EXPR, realtype,
ffecom_2 (MULT_EXPR, realtype,
a,
c),
ffecom_2 (MULT_EXPR, realtype,
b,
d)),
ffecom_2 (PLUS_EXPR, realtype,
ffecom_2 (MULT_EXPR, realtype,
a,
d),
ffecom_2 (MULT_EXPR, realtype,
c,
b)));
break;
case EQ_EXPR:
if ((TREE_CODE (node1) != RECORD_TYPE)
&& (TREE_CODE (node2) != RECORD_TYPE))
{
item = build (code, type, node1, node2);
break;
}
assert (TREE_CODE (node1) == RECORD_TYPE);
assert (TREE_CODE (node2) == RECORD_TYPE);
node1 = ffecom_stabilize_aggregate_ (node1);
node2 = ffecom_stabilize_aggregate_ (node2);
realtype = TREE_TYPE (TYPE_FIELDS (type));
item =
ffecom_2 (TRUTH_ANDIF_EXPR, type,
ffecom_2 (code, type,
ffecom_1 (REALPART_EXPR, realtype,
node1),
ffecom_1 (REALPART_EXPR, realtype,
node2)),
ffecom_2 (code, type,
ffecom_1 (IMAGPART_EXPR, realtype,
node1),
ffecom_1 (IMAGPART_EXPR, realtype,
node2)));
break;
case NE_EXPR:
if ((TREE_CODE (node1) != RECORD_TYPE)
&& (TREE_CODE (node2) != RECORD_TYPE))
{
item = build (code, type, node1, node2);
break;
}
assert (TREE_CODE (node1) == RECORD_TYPE);
assert (TREE_CODE (node2) == RECORD_TYPE);
node1 = ffecom_stabilize_aggregate_ (node1);
node2 = ffecom_stabilize_aggregate_ (node2);
realtype = TREE_TYPE (TYPE_FIELDS (type));
item =
ffecom_2 (TRUTH_ORIF_EXPR, type,
ffecom_2 (code, type,
ffecom_1 (REALPART_EXPR, realtype,
node1),
ffecom_1 (REALPART_EXPR, realtype,
node2)),
ffecom_2 (code, type,
ffecom_1 (IMAGPART_EXPR, realtype,
node1),
ffecom_1 (IMAGPART_EXPR, realtype,
node2)));
break;
default:
item = build (code, type, node1, node2);
break;
}
if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
TREE_SIDE_EFFECTS (item) = 1;
return fold (item);
}
bool
ffecom_2pass_advise_entrypoint (ffesymbol entry)
{
ffebld list;
ffebld mlist;
ffebld plist;
ffebld arg;
ffebld item;
ffesymbol s;
ffeinfoBasictype bt = ffesymbol_basictype (entry);
ffeinfoKindtype kt = ffesymbol_kindtype (entry);
ffetargetCharacterSize size = ffesymbol_size (entry);
bool ok;
if (ffecom_num_entrypoints_ == 0)
{
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;
item = ffebld_new_item (arg, NULL);
if (plist == NULL)
ffecom_master_arglist_ = item;
else
ffebld_set_trail (plist, item);
plist = item;
}
}
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;
}
}
}
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;
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;
}
++ffecom_num_entrypoints_;
for (list = ffesymbol_dummyargs (entry);
list != NULL;
list = ffebld_trail (list))
{
arg = ffebld_head (list);
if (ffebld_op (arg) != FFEBLD_opSYMTER)
continue;
s = ffebld_symter (arg);
for (plist = NULL, mlist = ffecom_master_arglist_;
mlist != NULL;
plist = mlist, mlist = ffebld_trail (mlist))
{
if (ffebld_symter (ffebld_head (mlist)) == s)
break;
}
if (mlist != NULL)
continue;
item = ffebld_new_item (arg, NULL);
if (plist == NULL)
ffecom_master_arglist_ = item;
else
ffebld_set_trail (plist, item);
}
return TRUE;
}
void
ffecom_2pass_do_entrypoint (ffesymbol entry)
{
static int mfn_num = 0;
static int ent_num;
if (mfn_num != ffecom_num_fns_)
{
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);
}
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);
}
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);
}
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);
}
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);
}
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;
}
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)))
{
#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
case FFEINFO_basictypeHOLLERITH:
#endif
case FFEINFO_basictypeCHARACTER:
break;
default:
item = ffecom_ptr_to_expr (expr);
if (item != error_mark_node)
*length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
break;
}
break;
default:
break;
}
#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
&& (length != NULL))
{
ffetargetHollerith h;
assert (ffebld_op (expr) == FFEBLD_opCONTER);
h = ffebld_cu_val_hollerith (ffebld_constant_union
(ffebld_conter (expr)));
*length
= build_int_2 (h.length, 0);
TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
}
#endif
if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
return ffecom_ptr_to_expr (expr);
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeCHARACTER1);
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:
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:
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:
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);
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;
}
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);
}
tree
ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
ffeinfoKindtype kt, tree tree_type)
{
tree item;
switch (bt)
{
case FFEINFO_basictypeINTEGER:
{
int val;
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
val = ffebld_cu_val_integer1 (*cu);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
val = ffebld_cu_val_integer2 (*cu);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
val = ffebld_cu_val_integer3 (*cu);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
val = ffebld_cu_val_integer4 (*cu);
break;
#endif
default:
assert ("bad INTEGER constant kind type" == NULL);
case FFEINFO_kindtypeANY:
return error_mark_node;
}
item = build_int_2 (val, (val < 0) ? -1 : 0);
TREE_TYPE (item) = tree_type;
}
break;
case FFEINFO_basictypeLOGICAL:
{
int val;
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
val = ffebld_cu_val_logical1 (*cu);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
val = ffebld_cu_val_logical2 (*cu);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
val = ffebld_cu_val_logical3 (*cu);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
val = ffebld_cu_val_logical4 (*cu);
break;
#endif
default:
assert ("bad LOGICAL constant kind type" == NULL);
case FFEINFO_kindtypeANY:
return error_mark_node;
}
item = build_int_2 (val, (val < 0) ? -1 : 0);
TREE_TYPE (item) = tree_type;
}
break;
case FFEINFO_basictypeREAL:
{
REAL_VALUE_TYPE val;
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
break;
#endif
default:
assert ("bad REAL constant kind type" == NULL);
case FFEINFO_kindtypeANY:
return error_mark_node;
}
item = build_real (tree_type, val);
}
break;
case FFEINFO_basictypeCOMPLEX:
{
REAL_VALUE_TYPE real;
REAL_VALUE_TYPE imag;
tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
break;
#endif
default:
assert ("bad REAL constant kind type" == NULL);
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:
{
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);
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 (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);
case FFEINFO_basictypeANY:
return error_mark_node;
}
TREE_CONSTANT (item) = 1;
return item;
}
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
#if NEWCOMMON
|| ffebld_where (expr) == FFEINFO_whereCOMMON
#endif
|| 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;
}
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);
}
int
ffecom_decode_include_option (char *spec)
{
return ffecom_decode_include_option_ (spec);
}
tree
ffecom_end_compstmt (void)
{
return bison_rule_compstmt_ ();
}
void
ffecom_end_transition ()
{
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);
}
for (item = ffecom_list_common_;
item != NULL;
item = ffebld_trail (item))
ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
ffecom_list_common_ = NULL;
}
void
ffecom_exec_transition ()
{
bool inhibited;
if (ffe_is_ffedebug ())
fprintf (dmpout, "; exec_stmt_transition\n");
inhibited = ffebad_inhibit ();
ffebad_set_inhibit (FALSE);
ffesymbol_drive (ffecom_sym_exec_transition);
ffeequiv_exec_transition ();
if (ffe_is_ffedebug ())
{
ffestorag_report ();
}
if (inhibited)
ffebad_set_inhibit (TRUE);
}
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;
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);
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)
{
#ifdef MOVE_EXPR
expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
dest_tree,
source_tree);
#else
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);
#endif
}
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);
}
tree
ffecom_expr (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
}
tree
ffecom_expr_assign (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
}
tree
ffecom_expr_assign_w (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
}
tree
ffecom_expr_rw (tree type, ffebld expr)
{
assert (expr != NULL);
assert (type == NULL_TREE || type == ffecom_type_expr (expr));
return stabilize_reference (ffecom_expr (expr));
}
tree
ffecom_expr_w (tree type, ffebld expr)
{
assert (expr != NULL);
assert (type == NULL_TREE || type == ffecom_type_expr (expr));
return stabilize_reference (ffecom_expr (expr));
}
void
ffecom_finish_compile ()
{
assert (ffecom_outer_function_decl_ == NULL_TREE);
assert (current_function_decl == NULL_TREE);
ffeglobal_drive (ffecom_finish_global_);
}
void
ffecom_finish_decl (tree decl, tree init, bool is_top_level)
{
assert (!is_top_level);
finish_decl (decl, init, FALSE);
}
void
ffecom_finish_progunit ()
{
ffecom_end_compstmt ();
ffecom_previous_function_decl_ = current_function_decl;
ffecom_which_entrypoint_decl_ = NULL_TREE;
finish_function (0);
}
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 ()
{
tree endlink;
int i;
int j;
tree t;
tree field;
ffetype type;
ffetype base_type;
tree double_ftype_double;
tree float_ftype_float;
tree ldouble_ftype_ldouble;
tree ffecom_tree_ptr_to_fun_type_void;
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;
pushlevel (0);
global_binding_level = current_binding_level;
current_binding_level->prep_state = 2;
build_common_tree_nodes (1);
pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
integer_type_node));
char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
char_type_node));
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_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);
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));
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));
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);
float_ftype_float
= build_function_type (float_type_node,
tree_cons (NULL_TREE, float_type_node, endlink));
double_ftype_double
= build_function_type (double_type_node,
tree_cons (NULL_TREE, double_type_node, endlink));
ldouble_ftype_ldouble
= build_function_type (long_double_type_node,
tree_cons (NULL_TREE, long_double_type_node,
endlink));
for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
{
ffecom_tree_type[i][j] = NULL_TREE;
ffecom_tree_fun_type[i][j] = NULL_TREE;
ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
ffecom_f2c_typecode_[i][j] = -1;
}
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);
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;
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));
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)
{
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;
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);
}
}
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_;
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);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
FFETARGET_f2cTYLONG);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
FFETARGET_f2cTYSHORT);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
FFETARGET_f2cTYINT1);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
FFETARGET_f2cTYQUAD);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
FFETARGET_f2cTYLOGICAL);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
FFETARGET_f2cTYLOGICAL2);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
FFETARGET_f2cTYLOGICAL1);
ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
FFETARGET_f2cTYQUAD);
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;
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;
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_);
ffecom_tree_subr_type
= build_function_type (integer_type_node, NULL_TREE);
ffecom_tree_ptr_to_subr_type
= build_pointer_type (ffecom_tree_subr_type);
ffecom_tree_blockdata_type
= build_function_type (void_type_node, NULL_TREE);
builtin_function ("__builtin_sqrtf", float_ftype_float,
BUILT_IN_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_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_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);
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);
{
REAL_VALUE_TYPE point_5;
REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
ffecom_float_half_ = build_real (float_type_node, point_5);
ffecom_double_half_ = build_real (double_type_node, point_5);
}
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
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
if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
< TYPE_PRECISION (string_type_node))
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
if (TYPE_PRECISION (ffecom_integer_type_node)
< TYPE_PRECISION (string_type_node))
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
}
void
ffecom_init_2 ()
{
assert (ffecom_outer_function_decl_ == NULL_TREE);
assert (current_function_decl == NULL_TREE);
assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
ffecom_master_arglist_ = NULL;
++ffecom_num_fns_;
ffecom_primary_entry_ = NULL;
ffecom_is_altreturning_ = FALSE;
ffecom_func_result_ = NULL_TREE;
ffecom_multi_retval_ = NULL_TREE;
}
tree
ffecom_list_expr (ffebld expr)
{
tree list;
tree *plist = &list;
tree trail = NULL_TREE;
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;
}
tree
ffecom_list_ptr_to_expr (ffebld expr)
{
tree list;
tree *plist = &list;
tree trail = NULL_TREE;
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;
}
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;
}
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);
}
void
ffecom_file (const char *name)
{
ffecom_file_ (name);
}
void
ffecom_notify_init_storage (ffestorag st)
{
ffebld init;
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);
}
}
void
ffecom_notify_init_symbol (ffesymbol s)
{
ffebld init;
if (ffesymbol_storage (s) == NULL)
return;
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);
}
}
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);
}
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;
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;
}
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;
}
void
ffecom_prepare_arg_ptr_to_expr (ffebld expr)
{
ffecom_prepare_expr (expr);
return;
}
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;
}
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));
if (bt == FFEINFO_basictypeCHARACTER)
{
while (ffebld_op (expr) == FFEBLD_opPAREN)
expr = ffebld_left (expr);
}
switch (ffebld_op (expr))
{
default:
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)
{
kt = FFEINFO_kindtypeREAL2;
}
else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
break;
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)
sz = 24;
tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
break;
default:
break;
}
break;
case FFEBLD_opCONCATENATE:
{
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;
}
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:
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;
}
void
ffecom_prepare_expr_rw (tree type, ffebld expr)
{
assert (type == NULL_TREE || type == ffecom_type_expr (expr));
ffecom_prepare_expr (expr);
return;
}
void
ffecom_prepare_expr_w (tree type, ffebld expr)
{
assert (type == NULL_TREE || type == ffecom_type_expr (expr));
ffecom_prepare_expr (expr);
return;
}
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);
}
void
ffecom_prepare_ptr_to_expr (ffebld expr)
{
ffecom_prepare_expr (expr);
return;
}
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;
}
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;
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_)))
{
rtn = NULL_TREE;
break;
}
rtn = ffecom_func_result_;
#if 0
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;
}
tree
ffecom_save_tree (tree t)
{
return save_expr (t);
}
void
ffecom_start_compstmt (void)
{
bison_rule_pushlevel_ ();
}
tree
ffecom_start_decl (tree decl, bool is_initialized)
{
DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
return start_decl (decl, FALSE);
}
void
ffecom_sym_commit (ffesymbol s UNUSED)
{
assert (!ffesymbol_retractable ());
}
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_);
}
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;
}
ffesymbol
ffecom_sym_exec_transition (ffesymbol s)
{
s = ffest_sym_exec_transition (s);
return s;
}
ffesymbol
ffecom_sym_learned (ffesymbol s)
{
ffestorag_exec_layout (s);
return s;
}
void
ffecom_sym_retract (ffesymbol s UNUSED)
{
assert (!ffesymbol_retractable ());
#if 0
switch (ffesymbol_hook (s).state)
{
case 0:
break;
case 1:
break;
case 2:
break;
case 3:
break;
case 4:
break;
default:
assert ("bad hook state" == NULL);
break;
}
#endif
}
tree
ffecom_temp_label ()
{
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;
}
tree
ffecom_truth_value (tree expr)
{
return ffe_truthvalue_conversion (expr);
}
tree
ffecom_truth_value_invert (tree expr)
{
return invert_truthvalue (ffecom_truth_value (expr));
}
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);
case FFEBLD_opANY:
return error_mark_node;
}
}
tree
ffecom_which_entrypoint_decl ()
{
assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
return ffecom_which_entrypoint_decl_;
}
static void
bison_rule_pushlevel_ ()
{
emit_line_note (input_filename, lineno);
pushlevel (0);
clear_last_expr ();
expand_start_bindings (0);
}
static tree
bison_rule_compstmt_ ()
{
tree t;
int keep = kept_level_p ();
if (! keep)
current_binding_level->names = NULL_TREE;
emit_line_note (input_filename, lineno);
expand_end_bindings (getdecls (), keep, 0);
t = poplevel (keep, 1, 0);
return t;
}
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;
}
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;
if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
return 0;
if (types_match && TREE_CODE (newdecl) == PARM_DECL
&& TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
return 1;
if (TREE_CODE (olddecl) == FUNCTION_DECL
&& DECL_BUILT_IN (olddecl))
{
if (!TREE_PUBLIC (newdecl))
return 0;
else if (!types_match)
{
tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
{
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)
{
if (!TREE_PUBLIC (newdecl))
return 0;
else if (!types_match)
{
TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
}
}
if (types_match)
{
if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
TREE_TYPE (newdecl)
= TREE_TYPE (olddecl)
= TREE_TYPE (newdecl);
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
{
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);
}
}
COPY_DECL_RTL (olddecl, newdecl);
if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
&& !TREE_THIS_VOLATILE (newdecl))
TREE_THIS_VOLATILE (olddecl) = 0;
if (TREE_READONLY (newdecl))
TREE_READONLY (olddecl) = 1;
if (TREE_THIS_VOLATILE (newdecl))
{
TREE_THIS_VOLATILE (olddecl) = 1;
if (TREE_CODE (newdecl) == VAR_DECL)
make_var_volatile (newdecl);
}
if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
|| (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
{
DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
if (DECL_CONTEXT (olddecl) == 0
&& TREE_CODE (newdecl) != FUNCTION_DECL)
DECL_CONTEXT (newdecl) = 0;
}
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;
if (DECL_INITIAL (newdecl) == 0)
DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
if (TREE_CODE (newdecl) == FUNCTION_DECL)
{
DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
}
}
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);
}
if (TREE_CODE (newdecl) == FUNCTION_DECL)
{
TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
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);
TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
}
else
{
TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
}
if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
DECL_INLINE (olddecl) = 1;
DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
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 (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);
}
{
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;
}
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;
assert (!is_top_level || !at_top_level);
if (TREE_CODE (decl) == PARM_DECL)
assert (init == NULL_TREE);
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
{
TREE_TYPE (decl) = TREE_TYPE (init);
DECL_INITIAL (decl) = init = 0;
}
}
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)
?
(DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
:
!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 ();
}
}
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)
{
if (was_incomplete
&& !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
{
TREE_ADDRESSABLE (decl) = TREE_USED (decl);
if (DECL_SIZE (decl) == 0)
DECL_INITIAL (decl) = 0;
expand_decl (decl);
}
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);
}
if (current_binding_level == global_binding_level)
get_pending_sizes ();
}
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);
}
poplevel (1, 0, 1);
if (TREE_CODE (fndecl) != ERROR_MARK)
{
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
expand_function_end (input_filename, lineno, 0, fndecl);
if (nested)
ggc_push_context ();
rest_of_compilation (fndecl);
if (nested)
ggc_pop_context ();
}
if (TREE_CODE (fndecl) != ERROR_MARK
&& !nested
&& DECL_SAVED_INSNS (fndecl) == 0)
{
if (DECL_INITIAL (fndecl) != 0)
DECL_INITIAL (fndecl) = error_mark_node;
DECL_ARGUMENTS (fndecl) = 0;
}
if (!nested)
{
ffecom_outer_function_decl_ = current_function_decl = NULL;
}
}
static const char *
ffe_printable_name (tree decl, int v)
{
switch (v)
{
default:
if (TREE_CODE (decl) == ERROR_MARK)
return "erroneous code";
return IDENTIFIER_POINTER (DECL_NAME (decl));
}
}
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;
}
}
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;
}
static struct f_binding_level *
make_binding_level ()
{
return ggc_alloc (sizeof (struct f_binding_level));
}
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;
static void
pop_f_function_context ()
{
struct f_function *p = f_function_chain;
tree link;
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)
{
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);
}
static void
push_f_function_context ()
{
struct f_function *p
= (struct f_function *) xmalloc (sizeof (struct f_function));
push_function_context ();
p->next = f_function_chain;
f_function_chain = p;
p->named_labels = named_labels;
p->shadowed_labels = shadowed_labels;
p->binding_level = current_binding_level;
}
static void
push_parm_decl (tree parm)
{
int old_immediate_size_expand = immediate_size_expand;
immediate_size_expand = 0;
DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
TREE_READONLY (parm) = 1;
parm = pushdecl (parm);
immediate_size_expand = old_immediate_size_expand;
finish_decl (parm, NULL_TREE, FALSE);
}
static tree
pushdecl_top_level (x)
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;
}
static tree
storedecls (decls)
tree decls;
{
return current_binding_level->names = decls;
}
static void
store_parm_decls (int is_main_program UNUSED)
{
register tree fndecl = current_function_decl;
if (fndecl == error_mark_node)
return;
DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
init_function_start (fndecl, input_filename, lineno);
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;
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);
DECL_COMMON (decl) = 1;
if (is_top_level)
tem = pushdecl_top_level (decl);
else
tem = pushdecl (decl);
if (!top_level
&& !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;
}
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;
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);
DECL_INITIAL (decl1) = error_mark_node;
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;
}
tree
convert (type, expr)
tree type, expr;
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
if (type == TREE_TYPE (e)
|| TREE_CODE (e) == ERROR_MARK)
return e;
if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
return fold (build1 (NOP_EXPR, type, e));
if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
|| code == ERROR_MARK)
return error_mark_node;
if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
{
assert ("void value not ignored as it ought to be" == NULL);
return error_mark_node;
}
if (code == VOID_TYPE)
return build1 (CONVERT_EXPR, type, e);
if ((code != RECORD_TYPE)
&& (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
e);
if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
return fold (convert_to_integer (type, e));
if (code == POINTER_TYPE)
return fold (convert_to_pointer (type, e));
if (code == REAL_TYPE)
return fold (convert_to_real (type, e));
if (code == COMPLEX_TYPE)
return fold (convert_to_complex (type, e));
if (code == RECORD_TYPE)
return fold (ffecom_convert_to_complex_ (type, e));
assert ("conversion to non-scalar type requested" == NULL);
return error_mark_node;
}
tree
getdecls ()
{
return current_binding_level->names;
}
int
global_bindings_p ()
{
return current_binding_level == global_binding_level;
}
static void
ffecom_init_decl_processing ()
{
malloc_init ();
ffe_init_0 ();
}
static void
delete_block (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;
TREE_USED (block) = 0;
}
void
insert_block (block)
tree block;
{
TREE_USED (block) = 1;
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
}
static const char *ffe_init PARAMS ((const char *));
static void ffe_finish PARAMS ((void));
static void ffe_init_options PARAMS ((void));
static void ffe_print_identifier PARAMS ((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_DECODE_OPTION
#define LANG_HOOKS_DECODE_OPTION ffe_decode_option
#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
#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;
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
const char tree_code_type[] = {
#include "tree.def"
};
#undef DEFTREECODE
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
const unsigned char tree_code_length[] = {
#include "tree.def"
};
#undef DEFTREECODE
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
const char *const tree_code_name[] = {
#include "tree.def"
};
#undef DEFTREECODE
static const char *
ffe_init (filename)
const char *filename;
{
if (filename == 0 || !strcmp (filename, "-"))
{
finput = stdin;
filename = "stdin";
}
else
finput = fopen (filename, "r");
if (finput == 0)
fatal_io_error ("can't open %s", filename);
#ifdef IO_BUFFER_SIZE
setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
#endif
ffecom_init_decl_processing ();
ffelex_hash_kludge (finput);
if (main_input_filename)
filename = main_input_filename;
return filename;
}
static void
ffe_finish ()
{
ffe_terminate_0 ();
if (ffe_is_ffedebug ())
malloc_pool_display (malloc_pool_image ());
fclose (finput);
}
static void
ffe_init_options ()
{
flag_move_all_movables = 1;
flag_reduce_all_givs = 1;
flag_argument_noalias = 2;
flag_merge_constants = 2;
flag_errno_math = 0;
flag_complex_divide_method = 1;
}
static bool
ffe_mark_addressable (exp)
tree exp;
{
register tree x = exp;
while (1)
switch (TREE_CODE (x))
{
case ADDR_EXPR:
case COMPONENT_REF:
case ARRAY_REF:
x = TREE_OPERAND (x, 0);
break;
case CONSTRUCTOR:
TREE_ADDRESSABLE (x) = 1;
return 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);
case FUNCTION_DECL:
TREE_ADDRESSABLE (x) = 1;
#if 0
if (DECL_CONTEXT (x) == 0)
TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
#endif
default:
return true;
}
}
tree
poplevel (keep, reverse, functionbody)
int keep;
int reverse;
int functionbody;
{
register tree link;
tree decls;
tree subblocks = current_binding_level->blocks;
tree block = 0;
tree decl;
int block_previously_created;
if (reverse)
current_binding_level->names
= decls = nreverse (current_binding_level->names);
else
decls = current_binding_level->names;
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 (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 ();
}
}
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;
}
for (link = subblocks; link; link = TREE_CHAIN (link))
BLOCK_SUPERCONTEXT (link) = block;
for (link = decls; link; link = TREE_CHAIN (link))
{
if (DECL_NAME (link) != 0)
{
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 (functionbody)
{
BLOCK_VARS (block) = 0;
}
{
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;
}
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);
}
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, node, indent)
FILE *file;
tree node;
int indent;
{
print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
}
tree
pushdecl (x)
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));
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 (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;
}
}
if (b == global_binding_level)
IDENTIFIER_GLOBAL_VALUE (name) = x;
else
IDENTIFIER_LOCAL_VALUE (name) = x;
}
TREE_CHAIN (x) = b->names;
b->names = x;
return x;
}
static int
kept_level_p ()
{
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)))
return 1;
}
return 0;
}
void
pushlevel (tag_transparent)
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;
}
if (free_binding_level)
{
newlevel = free_binding_level;
free_binding_level = free_binding_level->level_chain;
}
else
{
newlevel = make_binding_level ();
}
*newlevel = clear_binding_level;
newlevel->level_chain = current_binding_level;
current_binding_level = newlevel;
}
void
set_block (block)
register 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 (unsignedp, type)
int unsignedp;
tree type;
{
tree type2;
if (! INTEGRAL_TYPE_P (type))
return type;
if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
if (type2 == NULL_TREE)
return type;
return type2;
}
static tree
ffe_signed_type (type)
tree type;
{
tree type1 = TYPE_MAIN_VARIANT (type);
ffeinfoKindtype kt;
tree type2;
if (type1 == unsigned_char_type_node || type1 == char_type_node)
return signed_char_type_node;
if (type1 == unsigned_type_node)
return integer_type_node;
if (type1 == short_unsigned_type_node)
return short_integer_type_node;
if (type1 == long_unsigned_type_node)
return long_integer_type_node;
if (type1 == long_long_unsigned_type_node)
return long_long_integer_type_node;
#if 0
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;
}
static tree
ffe_truthvalue_conversion (expr)
tree expr;
{
if (TREE_CODE (expr) == ERROR_MARK)
return expr;
#if 0
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
switch (TREE_CODE (expr))
{
#if 0
case COMPONENT_REF:
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:
#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:
case FFS_EXPR:
return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
case LROTATE_EXPR:
case RROTATE_EXPR:
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:
{
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:
if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
|| TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
break;
case NOP_EXPR:
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:
if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
&& TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
break;
case BIT_XOR_EXPR:
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
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 (mode, unsignedp)
enum machine_mode mode;
int unsignedp;
{
int i;
int j;
tree t;
if (mode == TYPE_MODE (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (mode == TYPE_MODE (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (mode == TYPE_MODE (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (mode == TYPE_MODE (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (mode == TYPE_MODE (long_long_integer_type_node))
return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
#if 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 (bits, unsignedp)
unsigned bits;
int unsignedp;
{
ffeinfoKindtype kt;
tree type_node;
if (bits == TYPE_PRECISION (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (bits == TYPE_PRECISION (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (bits == TYPE_PRECISION (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (bits == TYPE_PRECISION (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (bits == TYPE_PRECISION (long_long_integer_type_node))
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
{
type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
: type_node;
}
return 0;
}
static tree
ffe_unsigned_type (type)
tree type;
{
tree type1 = TYPE_MAIN_VARIANT (type);
ffeinfoKindtype kt;
tree type2;
if (type1 == signed_char_type_node || type1 == char_type_node)
return unsigned_char_type_node;
if (type1 == integer_type_node)
return unsigned_type_node;
if (type1 == short_integer_type_node)
return short_unsigned_type_node;
if (type1 == long_integer_type_node)
return long_unsigned_type_node;
if (type1 == long_long_integer_type_node)
return long_long_unsigned_type_node;
#if 0
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;
}
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;
}
struct file_name_map
{
struct file_name_map *map_next;
char *map_from;
char *map_to;
};
#define FILE_NAME_MAP_FILE "header.gcc"
static int max_include_len = 0;
struct file_name_list
{
struct file_name_list *next;
char *fname;
struct file_name_map *name_map;
int got_name_map;
};
static struct file_name_list *include = NULL;
static struct file_name_list *last_include = NULL;
#define INPUT_STACK_MAX 400
static struct file_buf {
const char *fname;
const char *nominal_fname;
struct file_name_list *dir;
ffewhereLine line;
ffewhereColumn column;
} instack[INPUT_STACK_MAX];
static int last_error_tick = 0;
static int input_file_stack_tick = 0;
static int indepth = -1;
typedef struct file_buf FILE_BUF;
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);
static void
append_include_chain (first, last)
struct file_name_list *first, *last;
{
struct file_name_list *dir;
if (!first || !last)
return;
if (include == 0)
include = first;
else
last_include->next = first;
for (dir = first; ; dir = dir->next) {
int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
if (len > max_include_len)
max_include_len = len;
if (dir == last)
break;
}
last->next = NULL;
last_include = last;
}
static FILE *
open_include_file (filename, searchptr)
char *filename;
struct file_name_list *searchptr;
{
register struct file_name_map *map;
register char *from;
char *p, *dir;
if (searchptr && ! searchptr->got_name_map)
{
searchptr->name_map = read_name_map (searchptr->fname
? searchptr->fname : ".");
searchptr->got_name_map = 1;
}
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))
{
return fopen (map->map_to, "r");
}
}
}
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)))
{
return fopen (filename, "r");
}
if (p == filename)
{
from = filename;
map = read_name_map (".");
}
else
{
dir = (char *) 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");
}
static void
print_containing_files (ffebadSeverity sev)
{
FILE_BUF *ip = NULL;
int i;
int first = 1;
const char *str1;
const char *str2;
if (last_error_tick == input_file_stack_tick)
return;
for (i = indepth; i >= 0; i--)
if (instack[i].fname != NULL) {
ip = &instack[i];
break;
}
if (ip == NULL)
return;
for (i--; i >= 0; i--)
if (instack[i].fname != NULL)
{
ip = &instack[i];
if (first)
{
first = 0;
str1 = "In file included";
}
else
{
str1 = "... ...";
}
if (i == 1)
str2 = ":";
else
str2 = "";
ffebad_start_msg ("%A from %B at %0%C", sev);
ffebad_here (0, ip->line, ip->column);
ffebad_string (str1);
ffebad_string (ip->nominal_fname);
ffebad_string (str2);
ffebad_finish ();
}
last_error_tick = input_file_stack_tick;
}
static char *
read_filename_string (ch, f)
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;
}
static struct file_name_map *
read_name_map (dirname)
const char *dirname;
{
struct file_name_map_list
{
struct file_name_map_list *map_list_next;
char *map_list_name;
struct file_name_map *map_list_map;
};
static struct file_name_map_list *map_list;
register struct file_name_map_list *map_list_ptr;
char *name;
FILE *f;
size_t dirlen;
int separator_needed;
dirname = skip_redundant_dir_prefix (dirname);
for (map_list_ptr = map_list; map_list_ptr;
map_list_ptr = map_list_ptr->map_list_next)
if (! strcmp (map_list_ptr->map_list_name, dirname))
return map_list_ptr->map_list_map;
map_list_ptr = ((struct file_name_map_list *)
xmalloc (sizeof (struct file_name_map_list)));
map_list_ptr->map_list_name = 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 = ((struct file_name_map *)
xmalloc (sizeof (struct file_name_map)));
ptr->map_from = from;
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;
fp = &instack[++indepth];
memset ((char *) 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);
}
static int
ffecom_decode_include_option_ (char *spec)
{
struct file_name_list *dirtmp;
if (! ignore_srcdir && !strcmp (spec, "-"))
ignore_srcdir = 1;
else
{
dirtmp = (struct file_name_list *)
xmalloc (sizeof (struct file_name_list));
dirtmp->next = 0;
dirtmp->fname = spec;
dirtmp->got_name_map = 0;
if (spec[0] == 0)
error ("directory name must immediately follow -I");
else
append_include_chain (dirtmp, dirtmp);
}
return 1;
}
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;
struct file_name_list dsp[1];
struct file_name_list *searchptr = 0;
char *fname;
FILE *f;
FILE_BUF *fp;
if (flen == 0)
return NULL;
dsp[0].fname = NULL;
if (!ignore_srcdir)
{
for (fp = &instack[indepth]; fp >= instack; fp--)
{
int n;
char *ep;
const char *nam;
if ((nam = fp->nominal_fname) != NULL)
{
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
ep = strrchr (nam, ']');
if (ep == NULL) ep = strrchr (nam, '>');
if (ep == NULL) ep = strrchr (nam, ':');
if (ep != NULL) ep++;
#endif
if (ep != NULL)
{
n = ep - nam;
dsp[0].fname = (char *) xmalloc (n + 1);
strncpy (dsp[0].fname, nam, n);
dsp[0].fname[n] = '\0';
if (n + INCLUDE_LEN_FUDGE > max_include_len)
max_include_len = n + INCLUDE_LEN_FUDGE;
}
else
dsp[0].fname = NULL;
dsp[0].got_name_map = 0;
break;
}
}
}
fname = xmalloc (max_include_len + flen + 4);
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;
for (searchptr = search_start; searchptr; searchptr = searchptr->next)
{
if (searchptr->fname)
{
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
if (searchptr->fname && (searchptr->fname[0] != 0))
{
hack_vms_include_specification (fname);
}
else
{
strncpy (fname, (char *) fbeg, flen);
fname[flen] = 0;
#if 0
if (strchr (fname, '.') == NULL)
strcat (fname, ".h");
#endif
}
#endif
f = open_include_file (fname, searchptr);
#ifdef EACCES
if (f == NULL && errno == EACCES)
{
print_containing_files (FFEBAD_severityWARNING);
ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
FFEBAD_severityWARNING);
ffebad_string (fname);
ffebad_here (0, l, c);
ffebad_finish ();
}
#endif
if (f != NULL)
break;
}
}
if (f == NULL)
{
strncpy (fname, (char *) fbeg, flen);
fname[flen] = 0;
print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
ffebad_start (FFEBAD_OPEN_INCLUDE);
ffebad_here (0, l, c);
ffebad_string (fname);
ffebad_finish ();
}
if (dsp[0].fname != NULL)
free (dsp[0].fname);
if (f == NULL)
return NULL;
if (indepth >= (INPUT_STACK_MAX - 1))
{
print_containing_files (FFEBAD_severityFATAL);
ffebad_start_msg ("At %0, INCLUDE nesting too deep",
FFEBAD_severityFATAL);
ffebad_string (fname);
ffebad_here (0, l, c);
ffebad_finish ();
return NULL;
}
instack[indepth].line = ffewhere_line_use (l);
instack[indepth].column = ffewhere_column_use (c);
fp = &instack[indepth + 1];
memset ((char *) fp, 0, sizeof (FILE_BUF));
fp->nominal_fname = fp->fname = fname;
fp->dir = searchptr;
indepth++;
input_file_stack_tick++;
return f;
}
#include "gt-f-com.h"
#include "gtype-f.h"