is_nested, is_public);
// for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
store_parm_decls (is_main_program);
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
// for stmts and decls inside function, do appropriate things;
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
finish_function (is_nested);
if (is_nested) pop_f_function_context ();
if (is_nested) resume_momentary (yes);
tree char_type_node;
tree current_function_decl;
-/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
- it. */
+/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
+ reference it. */
char *language_string = "GNU F77";
#if FFECOM_targetCURRENT == FFECOM_targetGCC
typedef struct _ffecom_concat_list_ ffecomConcatList_;
-typedef struct _ffecom_temp_ *ffecomTemp_;
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Private include files. */
ffetargetCharacterSize minlen;
ffetargetCharacterSize maxlen;
};
-
-struct _ffecom_temp_
- {
- ffecomTemp_ next;
- tree type; /* Base type (w/o size/array applied). */
- tree t;
- ffetargetCharacterSize size;
- int elements;
- bool in_use;
- bool auto_pop;
- };
-
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Static functions (internal). */
bool is_f2c_complex, tree type,
tree args, tree dest_tree,
ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args);
+ 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 scalar_args, 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);
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 left, ffebld right);
+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,
#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
#endif
+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);
tree *size, tree tree);
static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
tree dest_tree, ffebld dest,
- bool *dest_used);
+ bool *dest_used, tree hook);
static tree ffecom_type_localvar_ (ffesymbol s,
ffeinfoBasictype bt,
ffeinfoKindtype kt);
end and thus have the same names. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void bison_rule_compstmt_ (void);
+static tree bison_rule_compstmt_ (void);
static void bison_rule_pushlevel_ (void);
static tree builtin_function (const char *name, tree type,
enum built_in_function function_code,
const char *library_name);
+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 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 tree ffecom_outer_function_decl_;
static tree ffecom_previous_function_decl_;
static tree ffecom_which_entrypoint_decl_;
-static ffecomTemp_ ffecom_latest_temp_;
-static int ffecom_pending_calls_ = 0;
static tree ffecom_float_zero_ = NULL_TREE;
static tree ffecom_float_half_ = NULL_TREE;
static tree ffecom_double_zero_ = NULL_TREE;
#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
-#define ffecom_start_compstmt_ bison_rule_pushlevel_
-#define ffecom_end_compstmt_ bison_rule_compstmt_
-
#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 binding_level
{
- /* A chain of _DECL nodes for all variables, constants, functions, and
- typedef types. These are in the reverse of the order supplied. */
+ /* A chain of _DECL nodes for all variables, constants, functions,
+ and typedef types. These are in the reverse of the order supplied.
+ */
tree names;
- /* For each level (except not the global one), a chain of BLOCK nodes for
- all the levels that were entered and exited one level down. */
+ /* For each level (except not the global one),
+ a chain of BLOCK nodes for all the levels
+ that were entered and exited one level down. */
tree blocks;
- /* The BLOCK node for this level, if one has been preallocated. If 0, the
- BLOCK is allocated (if needed) when the level is popped. */
+ /* The BLOCK node for this level, if one has been preallocated.
+ If 0, the BLOCK is allocated (if needed) when the level is popped. */
tree this_block;
/* The binding level which this one is contained in (inherits from). */
struct binding_level *level_chain;
+
+ /* 0: no ffecom_prepare_* functions called at this level yet;
+ 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
+ 2: ffecom_prepare_end called. */
+ int prep_state;
};
#define NULL_BINDING_LEVEL (struct binding_level *) NULL
static struct binding_level clear_binding_level
=
-{NULL, NULL, NULL, NULL_BINDING_LEVEL};
+{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
/* Language-dependent contents of an identifier. */
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
-
/* This is like gcc's stabilize_reference -- in fact, most of the code
comes from that -- but it handles the situation where the reference
is going to have its subparts picked at, and it shouldn't change
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)
+ bool scalar_args, tree hook)
{
tree item;
tree tempvar;
callee_commons,
scalar_args))
{
- tempvar = ffecom_push_tempvar (ffecom_tree_type
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (ffecom_tree_type
[FFEINFO_basictypeCOMPLEX][kt],
FFETARGET_charactersizeNONE,
- -1, TRUE);
+ -1);
+#else
+ tempvar = hook;
+ assert (tempvar);
+#endif
}
else
{
item
= build_tree_list (NULL_TREE,
ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (tempvar)),
+ build_pointer_type (TREE_TYPE (tempvar)),
tempvar));
TREE_CHAIN (item) = args;
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, ffebld left, ffebld right,
tree dest_tree, ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args)
+ tree callee_commons, bool scalar_args, tree hook)
{
tree left_tree;
tree right_tree;
tree left_length;
tree right_length;
- ffecom_push_calltemps ();
left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
- ffecom_pop_calltemps ();
left_tree = build_tree_list (NULL_TREE, left_tree);
right_tree = build_tree_list (NULL_TREE, right_tree);
return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
dest_tree, dest, dest_used, callee_commons,
- scalar_args);
+ scalar_args, hook);
}
#endif
-/* ffecom_char_args_x_ -- Return ptr/length args for char subexpression
-
- tree ptr_arg;
- tree length_arg;
- ffebld expr;
- bool with_null;
- ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
+/* Return ptr/length args for char subexpression
Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
subexpressions by constructing the appropriate trees for the ptr-to-
newlen = ffetarget_length_character1 (val);
if (with_null)
{
+ /* Begin FFETARGET-NULL-KLUDGE. */
if (newlen != 0)
- ++newlen; /* begin FFETARGET-NULL-KLUDGE. */
+ ++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, /* end FFETARGET-NULL-KLUDGE. */
+ item = build_string (newlen,
ffetarget_text_character1 (val));
+ /* End FFETARGET-NULL-KLUDGE. */
TREE_TYPE (item)
= build_type_variant
(build_array_type
}
else if (item == error_mark_node)
*length = error_mark_node;
- else /* FFEINFO_kindFUNCTION: */
+ else
+ /* FFEINFO_kindFUNCTION. */
*length = NULL_TREE;
if (!ffesymbol_hook (s).addr
&& (item != error_mark_node))
tree array;
int i;
- ffecom_push_calltemps ();
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
assert (ffebld_trail (thing) == NULL);
end = ffebld_head (thing);
- ffecom_push_calltemps ();
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
ffecomGfrt ix;
if (size == FFETARGET_charactersizeNONE)
- size = 24; /* ~~~~ Kludge alert! This should someday be fixed. */
+ /* ~~Kludge alert! This should someday be fixed. */
+ size = 24;
*length = build_int_2 (size, 0);
TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
== FFEINFO_whereINTRINSIC)
{
if (size == 1)
- { /* Invocation of an intrinsic returning CHARACTER*1. */
+ {
+ /* Invocation of an intrinsic returning CHARACTER*1. */
item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
NULL, NULL);
break;
item = ffecom_1_fn (item);
}
- assert (ffecom_pending_calls_ != 0);
+#ifdef HOHO
tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
tempvar = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (tempvar)),
tempvar);
- ffecom_push_calltemps ();
-
args = build_tree_list (NULL_TREE, tempvar);
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
item, args, NULL_TREE);
item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
tempvar);
-
- ffecom_pop_calltemps ();
}
break;
case FFEBLD_opCONVERT:
- ffecom_push_calltemps ();
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
tree args;
tree newlen;
- assert (ffecom_pending_calls_ != 0);
- tempvar = ffecom_push_tempvar (char_type_node,
- ffebld_size (expr), -1, TRUE);
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (char_type_node,
+ ffebld_size (expr), -1);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
tempvar = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (tempvar)),
tempvar);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
= build_tree_list (NULL_TREE, *length);
- item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args);
+ 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);
{
if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
tlen = ffecom_get_invented_identifier ("__g77_length_%s",
- ffesymbol_text (s), 0);
+ ffesymbol_text (s), -1);
else
tlen = ffecom_get_invented_identifier ("__g77_%s",
- "length", 0);
+ "length", -1);
tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
#if BUILT_FOR_270
DECL_ARTIFICIAL (tlen) = 1;
case FFEBLD_opARRAYREF:
case FFEBLD_opFUNCREF:
case FFEBLD_opSUBSTR:
- break; /* ~~Do useful truncations here. */
+ /* ~~Do useful truncations here. */
+ break;
default:
assert ("op changed or inconsistent switches!" == NULL);
}
#endif
-/* ffecom_concat_list_new_ -- Make list of concatenated string exprs
-
- ffecomConcatList_ catlist;
- ffebld expr; // Root expr of CHARACTER basictype.
- ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
- catlist = ffecom_concat_list_new_(expr,max);
+/* Make list of concatenated string exprs.
Returns a flattened list of concatenated subexpressions given a
tree of such expressions. */
type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ "result", -1);
/* Make length arg _and_ enhance type info for CHAR arg itself. */
store_parm_decls (0);
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
+ /* Disallow temp vars at this level. */
+ current_binding_level->prep_state = 2;
/* Make local var to hold return type for multi-type master fn. */
yes = suspend_momentary ();
multi_retval = ffecom_get_invented_identifier ("__g77_%s",
- "multi_retval", 0);
+ "multi_retval", -1);
multi_retval = build_decl (VAR_DECL, multi_retval,
ffecom_multi_type_node_);
multi_retval = start_decl (multi_retval, FALSE);
clear_momentary ();
}
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
finish_function (0);
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
return ffecom_1 (NOP_EXPR, tree_type, left);
- case FFEBLD_opPAREN: /* ~~~Make sure Fortran rules respected here */
+ case FFEBLD_opPAREN:
+ /* ~~~Make sure Fortran rules respected here */
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
return ffecom_1 (NOP_EXPR, tree_type, left);
right = convert (tree_type, right);
}
return ffecom_tree_divide_ (tree_type, left, right,
- dest_tree, dest, dest_used);
+ dest_tree, dest, dest_used,
+ ffebld_nonter_hook (expr));
case FFEBLD_opPOWER:
{
case FFEINFO_basictypeINTEGER:
if (1 || optimize)
{
- item = ffecom_expr_power_integer_ (left, right);
+ item = ffecom_expr_power_integer_ (expr);
if (item != NULL_TREE)
return item;
}
&& ffecom_gfrt_complex_[code]),
tree_type, left, right,
dest_tree, dest, dest_used,
- NULL_TREE, FALSE);
+ NULL_TREE, FALSE,
+ ffebld_nonter_hook (expr));
}
case FFEBLD_opNOT:
else
item = ffecom_1_fn (dt);
- ffecom_push_calltemps ();
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
args = ffecom_list_expr (ffebld_right (expr));
else
args = ffecom_list_ptr_to_expr (ffebld_right (expr));
- ffecom_pop_calltemps ();
if (args == error_mark_node)
return error_mark_node;
tree_type,
args,
dest_tree, dest, dest_used,
- error_mark_node, FALSE);
+ error_mark_node, FALSE,
+ ffebld_nonter_hook (expr));
TREE_SIDE_EFFECTS (item) = 1;
return item;
}
case FFEINFO_basictypeCHARACTER:
- ffecom_push_calltemps (); /* Even though we might not call. */
-
{
ffebld left = ffebld_left (expr);
ffebld right = ffebld_right (expr);
if (left_tree == error_mark_node || left_length == error_mark_node
|| right_tree == error_mark_node
|| right_length == error_mark_node)
- {
- ffecom_pop_calltemps ();
- return error_mark_node;
- }
+ return error_mark_node;
if ((ffebld_size_known (left) == 1)
&& (ffebld_size_known (right) == 1))
left_length);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
= build_tree_list (NULL_TREE, right_length);
- item = ffecom_call_gfrt (FFECOM_gfrtCMP, item);
+ item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
item = ffecom_2 (code, integer_type_node,
item,
convert (TREE_TYPE (item),
item = convert (tree_type, item);
}
- ffecom_pop_calltemps ();
return item;
default:
case FFEINTRIN_impAINT:
case FFEINTRIN_impDINT:
-#if 0 /* ~~ someday implement FIX_TRUNC_EXPR
- yielding same type as arg */
+#if 0
+ /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
#else /* in the meantime, must use floor to avoid range problems with ints */
/* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
build_tree_list (NULL_TREE,
convert (double_type_node,
- saved_expr1))),
+ 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))))
+ saved_expr1))),
+ NULL_TREE)
))
);
#endif
arg1_type,
saved_expr1,
convert (arg1_type,
- ffecom_float_half_))))),
+ ffecom_float_half_)))),
+ NULL_TREE),
ffecom_1 (NEGATE_EXPR, double_type_node,
ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
build_tree_list (NULL_TREE,
arg1_type,
convert (arg1_type,
ffecom_float_half_),
- saved_expr1)))))
+ saved_expr1))),
+ NULL_TREE))
)
);
#endif
case FFEINTRIN_impCHAR:
case FFEINTRIN_impACHAR:
- assert (ffecom_pending_calls_ != 0);
- tempvar = ffecom_push_tempvar (char_type_node,
- 1, -1, TRUE);
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
{
tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
case FFEINTRIN_impNINT:
case FFEINTRIN_impIDNINT:
-#if 0 /* ~~ ideally FIX_ROUND_EXPR would be
- implemented, but it ain't yet */
+#if 0
+ /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
#else
/* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
tree prep_arg4;
tree arg5_plus_arg3;
- ffecom_push_calltemps ();
-
arg2_tree = convert (integer_type_node,
ffecom_expr (arg2));
arg3_tree = ffecom_save_tree (convert (integer_type_node,
ffecom_expr (arg3)));
- arg4_tree = ffecom_expr_rw (arg4);
+ arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
arg4_type = TREE_TYPE (arg4_tree);
arg1_tree = ffecom_save_tree (convert (arg4_type,
arg5_tree = ffecom_save_tree (convert (integer_type_node,
ffecom_expr (arg5)));
- ffecom_pop_calltemps ();
-
prep_arg1
= ffecom_2 (LSHIFT_EXPR, arg4_type,
ffecom_2 (BIT_AND_EXPR, arg4_type,
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg2_tree);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
TREE_CHAIN (arg1_tree) = arg2_tree;
NULL_TREE :
tree_type),
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg2_tree);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
TREE_CHAIN (arg1_tree) = arg2_tree;
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
if (arg2 != NULL)
- arg2_tree = ffecom_expr_rw (arg2);
+ arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
else
arg2_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
TREE_CHAIN (arg1_tree) = arg1_len;
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg2_tree != NULL_TREE)
expr_tree
FALSE,
void_type_node,
expr_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
case FFEINTRIN_impFLUSH:
if (arg1 == NULL)
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ 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),
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
arg2_tree = ffecom_ptr_to_expr (arg2);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ 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),
tree arg2_len = integer_zero_node;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg1_tree);
arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ 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);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_tree),
expr_tree));
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg3 == NULL)
arg3_tree = NULL_TREE;
else
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ 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);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ 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),
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg3 == NULL)
arg3_tree = NULL_TREE;
else
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ 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);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ 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),
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
build_pointer_type (TREE_TYPE (arg2_tree)),
arg2_tree);
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
}
return expr_tree;
ffecom_f2c_real_type_node),
arg1_tree,
dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
}
return expr_tree;
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg2 == NULL)
arg2_tree = NULL_TREE;
else
- arg2_tree = ffecom_expr_rw (arg2);
-
- ffecom_pop_calltemps ();
+ arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
ffecom_gfrt_kindtype (gfrt),
NULL_TREE,
build_tree_list (NULL_TREE, arg1_tree),
NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE);
+ TRUE,
+ ffebld_nonter_hook (expr));
if (arg2_tree != NULL_TREE) {
expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
convert (TREE_TYPE (arg2_tree),
{
tree arg1_tree;
- ffecom_push_calltemps ();
-
- arg1_tree = ffecom_expr_rw (arg1);
-
- ffecom_pop_calltemps ();
+ arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
FALSE,
NULL_TREE,
NULL_TREE,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
expr_tree
= ffecom_modify (NULL_TREE, arg1_tree,
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
- arg1_tree = ffecom_expr_rw (arg1);
+ arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
arg2_tree = ffecom_ptr_to_expr (arg2);
- ffecom_pop_calltemps ();
-
expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
ffecom_gfrt_kindtype (gfrt),
FALSE,
NULL_TREE,
build_tree_list (NULL_TREE, arg2_tree),
NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE);
+ TRUE,
+ ffebld_nonter_hook (expr));
expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
convert (TREE_TYPE (arg1_tree),
expr_tree));
}
return expr_tree;
- /* Straightforward calls of libf2c routines: */
+ /* Straightforward calls of libf2c routines: */
case FFEINTRIN_impABORT:
case FFEINTRIN_impACCESS:
case FFEINTRIN_impBESJ0:
assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
- ffecom_push_calltemps ();
expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
ffebld_right (expr));
- ffecom_pop_calltemps ();
return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
(ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
tree_type,
expr_tree, dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
- /**INDENT* (Do not reformat this comment even with -fca option.)
- Data-gathering files: Given the source file listed below, compiled with
- f2c I obtained the output file listed after that, and from the output
- file I derived the above code.
+ /* See bottom of this file for f2c transforms used to determine
+ many of the above implementations. The info seems to confuse
+ Emacs's C mode indentation, which is why it's been moved to
+ the bottom of this source file. */
+}
--------- (begin input file to f2c)
- implicit none
- character*10 A1,A2
- complex C1,C2
- integer I1,I2
- real R1,R2
- double precision D1,D2
-C
- call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
-c /
- call fooI(I1/I2)
- call fooR(R1/I1)
- call fooD(D1/I1)
- call fooC(C1/I1)
- call fooR(R1/R2)
- call fooD(R1/D1)
- call fooD(D1/D2)
- call fooD(D1/R1)
- call fooC(C1/C2)
- call fooC(C1/R1)
- call fooZ(C1/D1)
-c **
- call fooI(I1**I2)
- call fooR(R1**I1)
- call fooD(D1**I1)
- call fooC(C1**I1)
- call fooR(R1**R2)
- call fooD(R1**D1)
- call fooD(D1**D2)
- call fooD(D1**R1)
- call fooC(C1**C2)
- call fooC(C1**R1)
- call fooZ(C1**D1)
-c FFEINTRIN_impABS
- call fooR(ABS(R1))
-c FFEINTRIN_impACOS
- call fooR(ACOS(R1))
-c FFEINTRIN_impAIMAG
- call fooR(AIMAG(C1))
-c FFEINTRIN_impAINT
- call fooR(AINT(R1))
-c FFEINTRIN_impALOG
- call fooR(ALOG(R1))
-c FFEINTRIN_impALOG10
- call fooR(ALOG10(R1))
-c FFEINTRIN_impAMAX0
- call fooR(AMAX0(I1,I2))
-c FFEINTRIN_impAMAX1
- call fooR(AMAX1(R1,R2))
-c FFEINTRIN_impAMIN0
- call fooR(AMIN0(I1,I2))
-c FFEINTRIN_impAMIN1
- call fooR(AMIN1(R1,R2))
-c FFEINTRIN_impAMOD
- call fooR(AMOD(R1,R2))
-c FFEINTRIN_impANINT
- call fooR(ANINT(R1))
-c FFEINTRIN_impASIN
- call fooR(ASIN(R1))
-c FFEINTRIN_impATAN
- call fooR(ATAN(R1))
-c FFEINTRIN_impATAN2
- call fooR(ATAN2(R1,R2))
-c FFEINTRIN_impCABS
- call fooR(CABS(C1))
-c FFEINTRIN_impCCOS
- call fooC(CCOS(C1))
-c FFEINTRIN_impCEXP
- call fooC(CEXP(C1))
-c FFEINTRIN_impCHAR
- call fooA(CHAR(I1))
-c FFEINTRIN_impCLOG
- call fooC(CLOG(C1))
-c FFEINTRIN_impCONJG
- call fooC(CONJG(C1))
-c FFEINTRIN_impCOS
- call fooR(COS(R1))
-c FFEINTRIN_impCOSH
- call fooR(COSH(R1))
-c FFEINTRIN_impCSIN
- call fooC(CSIN(C1))
-c FFEINTRIN_impCSQRT
- call fooC(CSQRT(C1))
-c FFEINTRIN_impDABS
- call fooD(DABS(D1))
-c FFEINTRIN_impDACOS
- call fooD(DACOS(D1))
-c FFEINTRIN_impDASIN
- call fooD(DASIN(D1))
-c FFEINTRIN_impDATAN
- call fooD(DATAN(D1))
-c FFEINTRIN_impDATAN2
- call fooD(DATAN2(D1,D2))
-c FFEINTRIN_impDCOS
- call fooD(DCOS(D1))
-c FFEINTRIN_impDCOSH
- call fooD(DCOSH(D1))
-c FFEINTRIN_impDDIM
- call fooD(DDIM(D1,D2))
-c FFEINTRIN_impDEXP
- call fooD(DEXP(D1))
-c FFEINTRIN_impDIM
- call fooR(DIM(R1,R2))
-c FFEINTRIN_impDINT
- call fooD(DINT(D1))
-c FFEINTRIN_impDLOG
- call fooD(DLOG(D1))
-c FFEINTRIN_impDLOG10
- call fooD(DLOG10(D1))
-c FFEINTRIN_impDMAX1
- call fooD(DMAX1(D1,D2))
-c FFEINTRIN_impDMIN1
- call fooD(DMIN1(D1,D2))
-c FFEINTRIN_impDMOD
- call fooD(DMOD(D1,D2))
-c FFEINTRIN_impDNINT
- call fooD(DNINT(D1))
-c FFEINTRIN_impDPROD
- call fooD(DPROD(R1,R2))
-c FFEINTRIN_impDSIGN
- call fooD(DSIGN(D1,D2))
-c FFEINTRIN_impDSIN
- call fooD(DSIN(D1))
-c FFEINTRIN_impDSINH
- call fooD(DSINH(D1))
-c FFEINTRIN_impDSQRT
- call fooD(DSQRT(D1))
-c FFEINTRIN_impDTAN
- call fooD(DTAN(D1))
-c FFEINTRIN_impDTANH
- call fooD(DTANH(D1))
-c FFEINTRIN_impEXP
- call fooR(EXP(R1))
-c FFEINTRIN_impIABS
- call fooI(IABS(I1))
-c FFEINTRIN_impICHAR
- call fooI(ICHAR(A1))
-c FFEINTRIN_impIDIM
- call fooI(IDIM(I1,I2))
-c FFEINTRIN_impIDNINT
- call fooI(IDNINT(D1))
-c FFEINTRIN_impINDEX
- call fooI(INDEX(A1,A2))
-c FFEINTRIN_impISIGN
- call fooI(ISIGN(I1,I2))
-c FFEINTRIN_impLEN
- call fooI(LEN(A1))
-c FFEINTRIN_impLGE
- call fooL(LGE(A1,A2))
-c FFEINTRIN_impLGT
- call fooL(LGT(A1,A2))
-c FFEINTRIN_impLLE
- call fooL(LLE(A1,A2))
-c FFEINTRIN_impLLT
- call fooL(LLT(A1,A2))
-c FFEINTRIN_impMAX0
- call fooI(MAX0(I1,I2))
-c FFEINTRIN_impMAX1
- call fooI(MAX1(R1,R2))
-c FFEINTRIN_impMIN0
- call fooI(MIN0(I1,I2))
-c FFEINTRIN_impMIN1
- call fooI(MIN1(R1,R2))
-c FFEINTRIN_impMOD
- call fooI(MOD(I1,I2))
-c FFEINTRIN_impNINT
- call fooI(NINT(R1))
-c FFEINTRIN_impSIGN
- call fooR(SIGN(R1,R2))
-c FFEINTRIN_impSIN
- call fooR(SIN(R1))
-c FFEINTRIN_impSINH
- call fooR(SINH(R1))
-c FFEINTRIN_impSQRT
- call fooR(SQRT(R1))
-c FFEINTRIN_impTAN
- call fooR(TAN(R1))
-c FFEINTRIN_impTANH
- call fooR(TANH(R1))
-c FFEINTRIN_imp_CMPLX_C
- call fooC(cmplx(C1,C2))
-c FFEINTRIN_imp_CMPLX_D
- call fooZ(cmplx(D1,D2))
-c FFEINTRIN_imp_CMPLX_I
- call fooC(cmplx(I1,I2))
-c FFEINTRIN_imp_CMPLX_R
- call fooC(cmplx(R1,R2))
-c FFEINTRIN_imp_DBLE_C
- call fooD(dble(C1))
-c FFEINTRIN_imp_DBLE_D
- call fooD(dble(D1))
-c FFEINTRIN_imp_DBLE_I
- call fooD(dble(I1))
-c FFEINTRIN_imp_DBLE_R
- call fooD(dble(R1))
-c FFEINTRIN_imp_INT_C
- call fooI(int(C1))
-c FFEINTRIN_imp_INT_D
- call fooI(int(D1))
-c FFEINTRIN_imp_INT_I
- call fooI(int(I1))
-c FFEINTRIN_imp_INT_R
- call fooI(int(R1))
-c FFEINTRIN_imp_REAL_C
- call fooR(real(C1))
-c FFEINTRIN_imp_REAL_D
- call fooR(real(D1))
-c FFEINTRIN_imp_REAL_I
- call fooR(real(I1))
-c FFEINTRIN_imp_REAL_R
- call fooR(real(R1))
-c
-c FFEINTRIN_imp_INT_D:
-c
-c FFEINTRIN_specIDINT
- call fooI(IDINT(D1))
-c
-c FFEINTRIN_imp_INT_R:
-c
-c FFEINTRIN_specIFIX
- call fooI(IFIX(R1))
-c FFEINTRIN_specINT
- call fooI(INT(R1))
-c
-c FFEINTRIN_imp_REAL_D:
-c
-c FFEINTRIN_specSNGL
- call fooR(SNGL(D1))
-c
-c FFEINTRIN_imp_REAL_I:
-c
-c FFEINTRIN_specFLOAT
- call fooR(FLOAT(I1))
-c FFEINTRIN_specREAL
- call fooR(REAL(I1))
-c
- end
--------- (end input file to f2c)
-
--------- (begin output from providing above input file as input to:
--------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
--------- -e "s:^#.*$::g"')
-
-// -- translated by f2c (version 19950223).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
-//
-
-
-// f2c.h -- Standard Fortran to C header file //
+#endif
+/* For power (exponentiation) where right-hand operand is type INTEGER,
+ generate in-line code to do it the fast way (which, if the operand
+ is a constant, might just mean a series of multiplies). */
-/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+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;
- - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
+ if (l == error_mark_node
+ || r == error_mark_node)
+ return error_mark_node;
+ if (TREE_CODE (r) == INTEGER_CST)
+ {
+ int sgn = tree_int_cst_sgn (r);
+ if (sgn == 0)
+ return convert (ltype, integer_one_node);
+ if ((TREE_CODE (ltype) == INTEGER_TYPE)
+ && (sgn < 0))
+ {
+ /* Reciprocal of integer is either 0, -1, or 1, so after
+ calculating that (which we leave to the back end to do
+ or not do optimally), don't bother with any multiplying. */
-// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
-// we assume short, float are OK //
-typedef long int // long int // integer;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef long int // long int // logical;
-typedef short int shortlogical;
-typedef char logical1;
-typedef char integer1;
-// typedef long long longint; // // system-dependent //
+ result = ffecom_tree_divide_ (ltype,
+ convert (ltype, integer_one_node),
+ l,
+ NULL_TREE, NULL, NULL, NULL_TREE);
+ r = ffecom_1 (NEGATE_EXPR,
+ rtype,
+ r);
+ if ((TREE_INT_CST_LOW (r) & 1) == 0)
+ result = ffecom_1 (ABS_EXPR, rtype,
+ result);
+ }
+ /* Generate appropriate series of multiplies, preceded
+ by divide if the exponent is negative. */
+ l = save_expr (l);
+ if (sgn < 0)
+ {
+ l = ffecom_tree_divide_ (ltype,
+ convert (ltype, integer_one_node),
+ l,
+ NULL_TREE, NULL, NULL,
+ ffebld_nonter_hook (expr));
+ r = ffecom_1 (NEGATE_EXPR, rtype, r);
+ assert (TREE_CODE (r) == INTEGER_CST);
-// Extern is for use with -E //
+ if (tree_int_cst_sgn (r) < 0)
+ { /* The "most negative" number. */
+ r = ffecom_1 (NEGATE_EXPR, rtype,
+ ffecom_2 (RSHIFT_EXPR, rtype,
+ r,
+ integer_one_node));
+ l = save_expr (l);
+ l = ffecom_2 (MULT_EXPR, ltype,
+ l,
+ l);
+ }
+ }
+ for (;;)
+ {
+ if (TREE_INT_CST_LOW (r) & 1)
+ {
+ if (result == NULL_TREE)
+ result = l;
+ else
+ result = ffecom_2 (MULT_EXPR, ltype,
+ result,
+ l);
+ }
+ r = ffecom_2 (RSHIFT_EXPR, rtype,
+ r,
+ integer_one_node);
+ if (integer_zerop (r))
+ break;
+ assert (TREE_CODE (r) == INTEGER_CST);
+ l = save_expr (l);
+ l = ffecom_2 (MULT_EXPR, ltype,
+ l,
+ l);
+ }
+ return result;
+ }
-// I/O stuff //
+ /* Though rhs isn't a constant, in-line code cannot be expanded
+ while transforming dummies
+ because the back end cannot be easily convinced to generate
+ stores (MODIFY_EXPR), handle temporaries, and so on before
+ all the appropriate rtx's have been generated for things like
+ dummy args referenced in rhs -- which doesn't happen until
+ store_parm_decls() is called (expand_function_start, I believe,
+ does the actual rtx-stuffing of PARM_DECLs).
+ So, in this case, let the caller generate the call to the
+ run-time-library function to evaluate the power for us. */
+ if (ffecom_transform_only_dummies_)
+ return NULL_TREE;
+ /* Right-hand operand not a constant, expand in-line code to figure
+ out how to do the multiplies, &c.
+ The returned expression is expressed this way in GNU C, where l and
+ r are the "inputs":
+ ({ typeof (r) rtmp = r;
+ typeof (l) ltmp = l;
+ typeof (l) result;
+ if (rtmp == 0)
+ result = 1;
+ else
+ {
+ if ((basetypeof (l) == basetypeof (int))
+ && (rtmp < 0))
+ {
+ result = ((typeof (l)) 1) / ltmp;
+ if ((ltmp < 0) && (((-rtmp) & 1) == 0))
+ result = -result;
+ }
+ else
+ {
+ result = 1;
+ if ((basetypeof (l) != basetypeof (int))
+ && (rtmp < 0))
+ {
+ ltmp = ((typeof (l)) 1) / ltmp;
+ rtmp = -rtmp;
+ if (rtmp < 0)
+ {
+ rtmp = -(rtmp >> 1);
+ ltmp *= ltmp;
+ }
+ }
+ for (;;)
+ {
+ if (rtmp & 1)
+ result *= ltmp;
+ if ((rtmp >>= 1) == 0)
+ break;
+ ltmp *= ltmp;
+ }
+ }
+ }
+ result;
+ })
+ Note that some of the above is compile-time collapsable, such as
+ the first part of the if statements that checks the base type of
+ l against int. The if statements are phrased that way to suggest
+ an easy way to generate the if/else constructs here, knowing that
+ the back end should (and probably does) eliminate the resulting
+ dead code (either the int case or the non-int case), something
+ it couldn't do without the redundant phrasing, requiring explicit
+ dead-code elimination here, which would be kind of difficult to
+ read. */
-typedef long int // int or long int // flag;
-typedef long int // int or long int // ftnlen;
-typedef long int // int or long int // ftnint;
+ {
+ 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);
-//external read, write//
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
+ se = expand_start_stmt_expr ();
-//internal read, write//
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
+ ffecom_start_compstmt ();
+
+#ifndef HAHA
+ 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;
+#else /* HAHA */
+ {
+ tree hook;
+
+ hook = ffebld_nonter_hook (expr);
+ assert (hook);
+ assert (TREE_CODE (hook) == TREE_VEC);
+ assert (TREE_VEC_LENGTH (hook) == 4);
+ rtmp = TREE_VEC_ELT (hook, 0);
+ ltmp = TREE_VEC_ELT (hook, 1);
+ result = TREE_VEC_ELT (hook, 2);
+ divide = TREE_VEC_ELT (hook, 3);
+ if (TREE_CODE (ltype) == COMPLEX_TYPE
+ || TREE_CODE (ltype) == RECORD_TYPE)
+ assert (divide);
+ else
+ assert (! divide);
+ }
+#endif /* HAHA */
-//open//
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ r));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ l));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (EQ_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype, integer_zero_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ convert (ltype, integer_one_node)));
+ expand_start_else ();
+ if (! integer_zerop (basetypeof_l_is_int))
+ {
+ expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype,
+ integer_zero_node)),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_tree_divide_
+ (ltype,
+ convert (ltype, integer_one_node),
+ ltmp,
+ NULL_TREE, NULL, NULL,
+ divide)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
+ ffecom_2 (LT_EXPR, integer_type_node,
+ ltmp,
+ convert (ltype,
+ integer_zero_node)),
+ ffecom_2 (EQ_EXPR, integer_type_node,
+ ffecom_2 (BIT_AND_EXPR,
+ rtype,
+ ffecom_1 (NEGATE_EXPR,
+ rtype,
+ rtmp),
+ convert (rtype,
+ integer_one_node)),
+ convert (rtype,
+ integer_zero_node)))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_1 (NEGATE_EXPR,
+ ltype,
+ result)));
+ expand_end_cond ();
+ expand_start_else ();
+ }
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ convert (ltype, integer_one_node)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
+ ffecom_truth_value_invert
+ (basetypeof_l_is_int),
+ ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype,
+ integer_zero_node)))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_tree_divide_
+ (ltype,
+ convert (ltype, integer_one_node),
+ ltmp,
+ NULL_TREE, NULL, NULL,
+ divide)));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ ffecom_1 (NEGATE_EXPR, rtype,
+ rtmp)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype, integer_zero_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ ffecom_1 (NEGATE_EXPR, rtype,
+ ffecom_2 (RSHIFT_EXPR,
+ rtype,
+ rtmp,
+ integer_one_node))));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_2 (MULT_EXPR, ltype,
+ ltmp,
+ ltmp)));
+ expand_end_cond ();
+ expand_end_cond ();
+ expand_start_loop (1);
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (BIT_AND_EXPR, rtype,
+ rtmp,
+ convert (rtype, integer_one_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_2 (MULT_EXPR, ltype,
+ result,
+ ltmp)));
+ expand_end_cond ();
+ expand_exit_loop_if_false (NULL,
+ ffecom_truth_value
+ (ffecom_modify (rtype,
+ rtmp,
+ ffecom_2 (RSHIFT_EXPR,
+ rtype,
+ rtmp,
+ integer_one_node))));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_2 (MULT_EXPR, ltype,
+ ltmp,
+ ltmp)));
+ expand_end_loop ();
+ expand_end_cond ();
+ if (!integer_zerop (basetypeof_l_is_int))
+ expand_end_cond ();
+ expand_expr_stmt (result);
-//close//
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
+ t = ffecom_end_compstmt ();
-//rewind, backspace, endfile//
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
+ result = expand_end_stmt_expr (se);
-// inquire //
-typedef struct
-{ flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; //parameters in standard's order//
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
-} inlist;
+ /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
+ if (TREE_CODE (t) == BLOCK)
+ {
+ /* Make a BIND_EXPR for the BLOCK already made. */
+ result = build (BIND_EXPR, TREE_TYPE (result),
+ NULL_TREE, result, t);
+ /* Remove the block from the tree at this point.
+ It gets put back at the proper place
+ when the BIND_EXPR is expanded. */
+ delete_block (t);
+ }
+ else
+ result = t;
+ }
+ return result;
+}
-union Multitype { // for multiple entry points //
- integer1 g;
- shortint h;
- integer i;
- // longint j; //
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
+#endif
+/* ffecom_expr_transform_ -- Transform symbols in expr
-typedef union Multitype Multitype;
+ ffebld expr; // FFE expression.
+ ffecom_expr_transform_ (expr);
-typedef long Long; // No longer used; formerly in Namelist //
+ Recursive descent on expr while transforming any untransformed SYMTERs. */
-struct Vardesc { // for Namelist //
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_expr_transform_ (ffebld expr)
+{
+ tree t;
+ ffesymbol s;
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
+tail_recurse: /* :::::::::::::::::::: */
+ if (expr == NULL)
+ return;
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opSYMTER:
+ s = ffebld_symter (expr);
+ t = ffesymbol_hook (s).decl_tree;
+ if ((t == NULL_TREE)
+ && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
+ || ((ffesymbol_where (s) != FFEINFO_whereNONE)
+ && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
+ {
+ s = ffecom_sym_transform_ (s);
+ t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
+ DIMENSION expr? */
+ }
+ break; /* Ok if (t == NULL) here. */
+ case FFEBLD_opITEM:
+ ffecom_expr_transform_ (ffebld_head (expr));
+ expr = ffebld_trail (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
+ default:
+ break;
+ }
+ switch (ffebld_arity (expr))
+ {
+ case 2:
+ ffecom_expr_transform_ (ffebld_left (expr));
+ expr = ffebld_right (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
+ case 1:
+ expr = ffebld_left (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
+ default:
+ break;
+ }
-// procedure parameter types for -A and -C++ //
+ return;
+}
+#endif
+/* Make a type based on info in live f2c.h file. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_f2c_make_type_ (tree *type, int tcode, 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;
-typedef int // Unknown procedure type // (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef // Complex // void (*C_fp)();
-typedef // Double Complex // void (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef // Character // void (*H_fp)();
-typedef // Subroutine // int (*S_fp)();
+ case FFECOM_f2ccodeINT:
+ *type = make_signed_type (INT_TYPE_SIZE);
+ break;
-// E_fp is for real functions when -R is not specified //
-typedef void C_f; // complex function //
-typedef void H_f; // character function //
-typedef void Z_f; // double complex function //
-typedef doublereal E_f; // real function with -R not specified //
+ case FFECOM_f2ccodeLONG:
+ *type = make_signed_type (LONG_TYPE_SIZE);
+ break;
-// undef any lower-case symbols that your C compiler predefines, e.g.: //
+ 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;
-// (No such symbols should be defined in a strict ANSI C compiler.
- We can avoid trouble with f2c-translated code by using
- gcc -ansi [-traditional].) //
+ 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, -1),
+ *type));
+}
+#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* Set the f2c list-directed-I/O code for whatever (integral) type has the
+ given size. */
+static void
+ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
+ int code)
+{
+ int j;
+ tree t;
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
+ && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
+ {
+ assert (code != -1);
+ ffecom_f2c_typecode_[bt][j] = code;
+ code = -1;
+ }
+}
+#endif
+/* Finish up globals after doing all program units in file
+ Need to handle only uninitialized COMMON areas. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffeglobal
+ffecom_finish_global_ (ffeglobal global)
+{
+ tree cbtype;
+ tree cbt;
+ tree size;
+ if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
+ return global;
+ if (ffeglobal_common_init (global))
+ return global;
+ cbt = ffeglobal_hook (global);
+ if ((cbt == NULL_TREE)
+ || !ffeglobal_common_have_size (global))
+ return global; /* No need to make common, never ref'd. */
+ suspend_momentary ();
+ DECL_EXTERNAL (cbt) = 0;
+ /* Give the array a size now. */
+ size = build_int_2 ((ffeglobal_common_size (global)
+ + 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;
+}
+#endif
+/* Finish up any untransformed symbols. */
-// Main program // MAIN__()
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffesymbol
+ffecom_finish_symbol_transform_ (ffesymbol s)
{
- // System generated locals //
- integer i__1;
- real r__1, r__2;
- doublereal d__1, d__2;
- complex q__1;
- doublecomplex z__1, z__2, z__3;
- logical L__1;
- char ch__1[1];
+ if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
+ return s;
- // Builtin functions //
- void c_div();
- integer pow_ii();
- double pow_ri(), pow_di();
- void pow_ci();
- double pow_dd();
- void pow_zz();
- double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
- asin(), atan(), atan2(), c_abs();
- void c_cos(), c_exp(), c_log(), r_cnjg();
- double cos(), cosh();
- void c_sin(), c_sqrt();
- double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
- d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
- integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
- logical l_ge(), l_gt(), l_le(), l_lt();
- integer i_nint();
- double r_sign();
+ /* It's easy to know to transform an untransformed symbol, to make sure
+ we put out debugging info for it. But COMMON variables, unlike
+ EQUIVALENCE ones, aren't given declarations in addition to the
+ tree expressions that specify offsets, because COMMON variables
+ can be referenced in the outer scope where only dummy arguments
+ (PARM_DECLs) should really be seen. To be safe, just don't do any
+ VAR_DECLs for COMMON variables when we transform them for real
+ use, and therefore we do all the VAR_DECL creating here. */
- // Local variables //
- extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
- fool_(), fooz_(), getem_();
- static char a1[10], a2[10];
- static complex c1, c2;
- static doublereal d1, d2;
- static integer i1, i2;
- static real r1, r2;
+ if (ffesymbol_hook (s).decl_tree == NULL_TREE)
+ {
+ if (ffesymbol_kind (s) != FFEINFO_kindNONE
+ || (ffesymbol_where (s) != FFEINFO_whereNONE
+ && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
+ && ffesymbol_where (s) != FFEINFO_whereDUMMY))
+ /* Not transformed, and not CHARACTER*(*), and not a dummy
+ argument, which can happen only if the entry point names
+ it "rides in on" are all invalidated for other reasons. */
+ s = ffecom_sym_transform_ (s);
+ }
+ if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
+ && (ffesymbol_hook (s).decl_tree != error_mark_node))
+ {
+#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
+ int yes = suspend_momentary ();
- getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
-// / //
- i__1 = i1 / i2;
- fooi_(&i__1);
- r__1 = r1 / i1;
- foor_(&r__1);
- d__1 = d1 / i1;
- food_(&d__1);
- d__1 = (doublereal) i1;
- q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
- fooc_(&q__1);
- r__1 = r1 / r2;
- foor_(&r__1);
- d__1 = r1 / d1;
- food_(&d__1);
- d__1 = d1 / d2;
- food_(&d__1);
- d__1 = d1 / r1;
- food_(&d__1);
- c_div(&q__1, &c1, &c2);
- fooc_(&q__1);
- q__1.r = c1.r / r1, q__1.i = c1.i / r1;
- fooc_(&q__1);
- z__1.r = c1.r / d1, z__1.i = c1.i / d1;
- fooz_(&z__1);
-// ** //
- i__1 = pow_ii(&i1, &i2);
- fooi_(&i__1);
- r__1 = pow_ri(&r1, &i1);
- foor_(&r__1);
- d__1 = pow_di(&d1, &i1);
- food_(&d__1);
- pow_ci(&q__1, &c1, &i1);
- fooc_(&q__1);
- d__1 = (doublereal) r1;
- d__2 = (doublereal) r2;
- r__1 = pow_dd(&d__1, &d__2);
- foor_(&r__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d__2, &d1);
- food_(&d__1);
- d__1 = pow_dd(&d1, &d2);
- food_(&d__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d1, &d__2);
- food_(&d__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = c2.r, z__3.i = c2.i;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = r1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = d1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- fooz_(&z__1);
-// FFEINTRIN_impABS //
- r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
- foor_(&r__1);
-// FFEINTRIN_impACOS //
- r__1 = acos(r1);
- foor_(&r__1);
-// FFEINTRIN_impAIMAG //
- r__1 = r_imag(&c1);
- foor_(&r__1);
-// FFEINTRIN_impAINT //
- r__1 = r_int(&r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG //
- r__1 = log(r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG10 //
- r__1 = r_lg10(&r1);
- foor_(&r__1);
-// FFEINTRIN_impAMAX0 //
- r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMAX1 //
- r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN0 //
- r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN1 //
- r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMOD //
- r__1 = r_mod(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impANINT //
- r__1 = r_nint(&r1);
- foor_(&r__1);
-// FFEINTRIN_impASIN //
- r__1 = asin(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN //
- r__1 = atan(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN2 //
- r__1 = atan2(r1, r2);
- foor_(&r__1);
-// FFEINTRIN_impCABS //
- r__1 = c_abs(&c1);
- foor_(&r__1);
-// FFEINTRIN_impCCOS //
- c_cos(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCEXP //
- c_exp(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCHAR //
- *(unsigned char *)&ch__1[0] = i1;
- fooa_(ch__1, 1L);
-// FFEINTRIN_impCLOG //
- c_log(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCONJG //
- r_cnjg(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCOS //
- r__1 = cos(r1);
- foor_(&r__1);
-// FFEINTRIN_impCOSH //
- r__1 = cosh(r1);
- foor_(&r__1);
-// FFEINTRIN_impCSIN //
- c_sin(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCSQRT //
- c_sqrt(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impDABS //
- d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
- food_(&d__1);
-// FFEINTRIN_impDACOS //
- d__1 = acos(d1);
- food_(&d__1);
-// FFEINTRIN_impDASIN //
- d__1 = asin(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN //
- d__1 = atan(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN2 //
- d__1 = atan2(d1, d2);
- food_(&d__1);
-// FFEINTRIN_impDCOS //
- d__1 = cos(d1);
- food_(&d__1);
-// FFEINTRIN_impDCOSH //
- d__1 = cosh(d1);
- food_(&d__1);
-// FFEINTRIN_impDDIM //
- d__1 = d_dim(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDEXP //
- d__1 = exp(d1);
- food_(&d__1);
-// FFEINTRIN_impDIM //
- r__1 = r_dim(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impDINT //
- d__1 = d_int(&d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG //
- d__1 = log(d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG10 //
- d__1 = d_lg10(&d1);
- food_(&d__1);
-// FFEINTRIN_impDMAX1 //
- d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMIN1 //
- d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMOD //
- d__1 = d_mod(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDNINT //
- d__1 = d_nint(&d1);
- food_(&d__1);
-// FFEINTRIN_impDPROD //
- d__1 = (doublereal) r1 * r2;
- food_(&d__1);
-// FFEINTRIN_impDSIGN //
- d__1 = d_sign(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDSIN //
- d__1 = sin(d1);
- food_(&d__1);
-// FFEINTRIN_impDSINH //
- d__1 = sinh(d1);
- food_(&d__1);
-// FFEINTRIN_impDSQRT //
- d__1 = sqrt(d1);
- food_(&d__1);
-// FFEINTRIN_impDTAN //
- d__1 = tan(d1);
- food_(&d__1);
-// FFEINTRIN_impDTANH //
- d__1 = tanh(d1);
- food_(&d__1);
-// FFEINTRIN_impEXP //
- r__1 = exp(r1);
- foor_(&r__1);
-// FFEINTRIN_impIABS //
- i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impICHAR //
- i__1 = *(unsigned char *)a1;
- fooi_(&i__1);
-// FFEINTRIN_impIDIM //
- i__1 = i_dim(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impIDNINT //
- i__1 = i_dnnt(&d1);
- fooi_(&i__1);
-// FFEINTRIN_impINDEX //
- i__1 = i_indx(a1, a2, 10L, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impISIGN //
- i__1 = i_sign(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impLEN //
- i__1 = i_len(a1, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impLGE //
- L__1 = l_ge(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLGT //
- L__1 = l_gt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLE //
- L__1 = l_le(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLT //
- L__1 = l_lt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impMAX0 //
- i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMAX1 //
- i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN0 //
- i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN1 //
- i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMOD //
- i__1 = i1 % i2;
- fooi_(&i__1);
-// FFEINTRIN_impNINT //
- i__1 = i_nint(&r1);
- fooi_(&i__1);
-// FFEINTRIN_impSIGN //
- r__1 = r_sign(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impSIN //
- r__1 = sin(r1);
- foor_(&r__1);
-// FFEINTRIN_impSINH //
- r__1 = sinh(r1);
- foor_(&r__1);
-// FFEINTRIN_impSQRT //
- r__1 = sqrt(r1);
- foor_(&r__1);
-// FFEINTRIN_impTAN //
- r__1 = tan(r1);
- foor_(&r__1);
-// FFEINTRIN_impTANH //
- r__1 = tanh(r1);
- foor_(&r__1);
-// FFEINTRIN_imp_CMPLX_C //
- r__1 = c1.r;
- r__2 = c2.r;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_D //
- z__1.r = d1, z__1.i = d2;
- fooz_(&z__1);
-// FFEINTRIN_imp_CMPLX_I //
- r__1 = (real) i1;
- r__2 = (real) i2;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_R //
- q__1.r = r1, q__1.i = r2;
- fooc_(&q__1);
-// FFEINTRIN_imp_DBLE_C //
- d__1 = (doublereal) c1.r;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_D //
- d__1 = d1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_I //
- d__1 = (doublereal) i1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_R //
- d__1 = (doublereal) r1;
- food_(&d__1);
-// FFEINTRIN_imp_INT_C //
- i__1 = (integer) c1.r;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_D //
- i__1 = (integer) d1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_I //
- i__1 = i1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_R //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_imp_REAL_C //
- r__1 = c1.r;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_D //
- r__1 = (real) d1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_I //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_R //
- r__1 = r1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_INT_D: //
-
-// FFEINTRIN_specIDINT //
- i__1 = (integer) d1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_INT_R: //
-
-// FFEINTRIN_specIFIX //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_specINT //
- i__1 = (integer) r1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_REAL_D: //
-
-// FFEINTRIN_specSNGL //
- r__1 = (real) d1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_REAL_I: //
-
-// FFEINTRIN_specFLOAT //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_specREAL //
- r__1 = (real) i1;
- foor_(&r__1);
-
-} // MAIN__ //
-
--------- (end output file from f2c)
-
-*/
-}
-
-#endif
-/* For power (exponentiation) where right-hand operand is type INTEGER,
- generate in-line code to do it the fast way (which, if the operand
- is a constant, might just mean a series of multiplies). */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_expr_power_integer_ (ffebld left, ffebld right)
-{
- tree l = ffecom_expr (left);
- tree r = ffecom_expr (right);
- tree ltype = TREE_TYPE (l);
- tree rtype = TREE_TYPE (r);
- tree result = NULL_TREE;
-
- if (l == error_mark_node
- || r == error_mark_node)
- return error_mark_node;
-
- if (TREE_CODE (r) == INTEGER_CST)
- {
- int sgn = tree_int_cst_sgn (r);
-
- if (sgn == 0)
- return convert (ltype, integer_one_node);
-
- if ((TREE_CODE (ltype) == INTEGER_TYPE)
- && (sgn < 0))
- {
- /* Reciprocal of integer is either 0, -1, or 1, so after
- calculating that (which we leave to the back end to do
- or not do optimally), don't bother with any multiplying. */
-
- result = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL);
- r = ffecom_1 (NEGATE_EXPR,
- rtype,
- r);
- if ((TREE_INT_CST_LOW (r) & 1) == 0)
- result = ffecom_1 (ABS_EXPR, rtype,
- result);
- }
-
- /* Generate appropriate series of multiplies, preceded
- by divide if the exponent is negative. */
-
- l = save_expr (l);
-
- if (sgn < 0)
- {
- l = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL);
- r = ffecom_1 (NEGATE_EXPR, rtype, r);
- assert (TREE_CODE (r) == INTEGER_CST);
-
- if (tree_int_cst_sgn (r) < 0)
- { /* The "most negative" number. */
- r = ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node));
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- }
-
- for (;;)
- {
- if (TREE_INT_CST_LOW (r) & 1)
- {
- if (result == NULL_TREE)
- result = l;
- else
- result = ffecom_2 (MULT_EXPR, ltype,
- result,
- l);
- }
-
- r = ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node);
- if (integer_zerop (r))
- break;
- assert (TREE_CODE (r) == INTEGER_CST);
+ /* This isn't working, at least for dbxout. The .s file looks
+ okay to me (burley), but in gdb 4.9 at least, the variables
+ appear to reside somewhere outside of the common area, so
+ it doesn't make sense to mislead anyone by generating the info
+ on those variables until this is fixed. NOTE: Same problem
+ with EQUIVALENCE, sadly...see similar #if later. */
+ ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
+ ffesymbol_storage (s));
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- return result;
+ resume_momentary (yes);
+#endif
}
- /* Though rhs isn't a constant, in-line code cannot be expanded
- while transforming dummies
- because the back end cannot be easily convinced to generate
- stores (MODIFY_EXPR), handle temporaries, and so on before
- all the appropriate rtx's have been generated for things like
- dummy args referenced in rhs -- which doesn't happen until
- store_parm_decls() is called (expand_function_start, I believe,
- does the actual rtx-stuffing of PARM_DECLs).
+ return s;
+}
- So, in this case, let the caller generate the call to the
- run-time-library function to evaluate the power for us. */
+#endif
+/* Append underscore(s) to name before calling get_identifier. "us"
+ is nonzero if the name already contains an underscore and thus
+ needs two underscores appended. */
- if (ffecom_transform_only_dummies_)
- return NULL_TREE;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_get_appended_identifier_ (char us, const char *name)
+{
+ int i;
+ char *newname;
+ tree id;
- /* Right-hand operand not a constant, expand in-line code to figure
- out how to do the multiplies, &c.
+ 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);
- The returned expression is expressed this way in GNU C, where l and
- r are the "inputs":
+ free (newname);
- ({ typeof (r) rtmp = r;
- typeof (l) ltmp = l;
- typeof (l) result;
+ return id;
+}
- if (rtmp == 0)
- result = 1;
- else
- {
- if ((basetypeof (l) == basetypeof (int))
- && (rtmp < 0))
- {
- result = ((typeof (l)) 1) / ltmp;
- if ((ltmp < 0) && (((-rtmp) & 1) == 0))
- result = -result;
- }
- else
- {
- result = 1;
- if ((basetypeof (l) != basetypeof (int))
- && (rtmp < 0))
- {
- ltmp = ((typeof (l)) 1) / ltmp;
- rtmp = -rtmp;
- if (rtmp < 0)
- {
- rtmp = -(rtmp >> 1);
- ltmp *= ltmp;
- }
- }
- for (;;)
- {
- if (rtmp & 1)
- result *= ltmp;
- if ((rtmp >>= 1) == 0)
- break;
- ltmp *= ltmp;
- }
- }
- }
- result;
- })
+#endif
+/* Decide whether to append underscore to name before calling
+ get_identifier. */
- Note that some of the above is compile-time collapsable, such as
- the first part of the if statements that checks the base type of
- l against int. The if statements are phrased that way to suggest
- an easy way to generate the if/else constructs here, knowing that
- the back end should (and probably does) eliminate the resulting
- dead code (either the int case or the non-int case), something
- it couldn't do without the redundant phrasing, requiring explicit
- dead-code elimination here, which would be kind of difficult to
- read. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_get_external_identifier_ (ffesymbol s)
+{
+ char us;
+ const char *name = ffesymbol_text (s);
- {
- tree rtmp;
- tree ltmp;
- tree basetypeof_l_is_int;
- tree se;
+ /* If name is a built-in name, just return it as is. */
- basetypeof_l_is_int
- = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
+ 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);
- se = expand_start_stmt_expr ();
- ffecom_push_calltemps ();
+ us = ffe_is_second_underscore ()
+ ? (strchr (name, '_') != NULL)
+ : 0;
- rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1,
- TRUE);
- ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
- TRUE);
- result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
- TRUE);
+ return ffecom_get_appended_identifier_ (us, name);
+}
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- r));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- l));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (EQ_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_else ();
- if (!integer_zerop (basetypeof_l_is_int))
- {
- expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_2 (LT_EXPR, integer_type_node,
- ltmp,
- convert (ltype,
- integer_zero_node)),
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_2 (BIT_AND_EXPR,
- rtype,
- ffecom_1 (NEGATE_EXPR,
- rtype,
- rtmp),
- convert (rtype,
- integer_one_node)),
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_1 (NEGATE_EXPR,
- ltype,
- result)));
- expand_end_cond ();
- expand_start_else ();
- }
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_truth_value_invert
- (basetypeof_l_is_int),
- ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL)));
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- rtmp)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_cond ();
- expand_end_cond ();
- expand_start_loop (1);
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (BIT_AND_EXPR, rtype,
- rtmp,
- convert (rtype, integer_one_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_2 (MULT_EXPR, ltype,
- result,
- ltmp)));
- expand_end_cond ();
- expand_exit_loop_if_false (NULL,
- ffecom_truth_value
- (ffecom_modify (rtype,
- rtmp,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_loop ();
- expand_end_cond ();
- if (!integer_zerop (basetypeof_l_is_int))
- expand_end_cond ();
- expand_expr_stmt (result);
+#endif
+/* Decide whether to append underscore to internal name before calling
+ get_identifier.
+
+ This is for non-external, top-function-context names only. Transform
+ identifier so it doesn't conflict with the transformed result
+ of using a _different_ external name. E.g. if "CALL FOO" is
+ transformed into "FOO_();", then the variable in "FOO_ = 3"
+ must be transformed into something that does not conflict, since
+ these two things should be independent.
- ffecom_pop_calltemps ();
- result = expand_end_stmt_expr (se);
- TREE_SIDE_EFFECTS (result) = 1;
- }
+ The transformation is as follows. If the name does not contain
+ an underscore, there is no possible conflict, so just return.
+ If the name does contain an underscore, then transform it just
+ like we transform an external identifier. */
- return result;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_get_identifier_ (const char *name)
+{
+ /* If name does not contain an underscore, just return it as is. */
+
+ if (!ffe_is_underscoring ()
+ || (strchr (name, '_') == NULL))
+ return get_identifier (name);
+
+ return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
+ name);
}
#endif
-/* ffecom_expr_transform_ -- Transform symbols in expr
+/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
- ffebld expr; // FFE expression.
- ffecom_expr_transform_ (expr);
+ tree t;
+ ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
+ t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
+ ffesymbol_kindtype(s));
- Recursive descent on expr while transforming any untransformed SYMTERs. */
+ Call after setting up containing function and getting trees for all
+ other symbols. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_expr_transform_ (ffebld expr)
+static tree
+ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
{
- tree t;
- ffesymbol s;
+ ffebld expr = ffesymbol_sfexpr (s);
+ tree type;
+ tree func;
+ tree result;
+ bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
+ static bool recurse = FALSE;
+ int yes;
+ int old_lineno = lineno;
+ char *old_input_filename = input_filename;
-tail_recurse: /* :::::::::::::::::::: */
+ ffecom_nested_entry_ = s;
- if (expr == NULL)
- return;
+ /* For now, we don't have a handy pointer to where the sfunc is actually
+ defined, though that should be easy to add to an ffesymbol. (The
+ token/where info available might well point to the place where the type
+ of the sfunc is declared, especially if that precedes the place where
+ the sfunc itself is defined, which is typically the case.) We should
+ put out a null pointer rather than point somewhere wrong, but I want to
+ see how it works at this point. */
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- t = ffesymbol_hook (s).decl_tree;
- if ((t == NULL_TREE)
- && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
- DIMENSION expr? */
- }
- break; /* Ok if (t == NULL) here. */
+ input_filename = ffesymbol_where_filename (s);
+ lineno = ffesymbol_where_filelinenum (s);
- case FFEBLD_opITEM:
- ffecom_expr_transform_ (ffebld_head (expr));
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ /* Pretransform the expression so any newly discovered things belong to the
+ outer program unit, not to the statement function. */
- default:
- break;
- }
+ ffecom_expr_transform_ (expr);
- switch (ffebld_arity (expr))
+ /* Make sure no recursive invocation of this fn (a specific case of failing
+ to pretransform an sfunc's expression, i.e. where its expression
+ references another untransformed sfunc) happens. */
+
+ assert (!recurse);
+ recurse = TRUE;
+
+ yes = suspend_momentary ();
+
+ push_f_function_context ();
+
+ if (charfunc)
+ type = void_type_node;
+ else
{
- case 2:
- ffecom_expr_transform_ (ffebld_left (expr));
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ type = ffecom_tree_type[bt][kt];
+ if (type == NULL_TREE)
+ type = integer_type_node; /* _sym_exec_transition reports
+ error. */
+ }
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
+ build_function_type (type, NULL_TREE),
+ 1, /* nested/inline */
+ 0); /* TREE_PUBLIC */
- default:
- break;
+ /* We don't worry about COMPLEX return values here, because this is
+ entirely internal to our code, and gcc has the ability to return COMPLEX
+ directly as a value. */
+
+ yes = suspend_momentary ();
+
+ if (charfunc)
+ { /* Prepend arg for where result goes. */
+ tree type;
+
+ type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
+
+ result = ffecom_get_invented_identifier ("__g77_%s",
+ "result", -1);
+
+ ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
+
+ type = build_pointer_type (type);
+ result = build_decl (PARM_DECL, result, type);
+
+ push_parm_decl (result);
}
+ else
+ result = NULL_TREE; /* Not ref'd if !charfunc. */
- return;
-}
+ ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
-#endif
-/* Make a type based on info in live f2c.h file. */
+ resume_momentary (yes);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
-{
- switch (tcode)
+ store_parm_decls (0);
+
+ ffecom_start_compstmt ();
+
+ if (expr != NULL)
{
- case FFECOM_f2ccodeCHAR:
- *type = make_signed_type (CHAR_TYPE_SIZE);
- break;
+ if (charfunc)
+ {
+ ffetargetCharacterSize sz = ffesymbol_size (s);
+ tree result_length;
- case FFECOM_f2ccodeSHORT:
- *type = make_signed_type (SHORT_TYPE_SIZE);
- break;
+ result_length = build_int_2 (sz, 0);
+ TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
- case FFECOM_f2ccodeINT:
- *type = make_signed_type (INT_TYPE_SIZE);
- break;
+ ffecom_prepare_let_char_ (sz, expr);
- case FFECOM_f2ccodeLONG:
- *type = make_signed_type (LONG_TYPE_SIZE);
- break;
+ ffecom_prepare_end ();
- case FFECOM_f2ccodeLONGLONG:
- *type = make_signed_type (LONG_LONG_TYPE_SIZE);
- break;
+ ffecom_let_char_ (result, result_length, sz, expr);
+ expand_null_return ();
+ }
+ else
+ {
+ ffecom_prepare_expr (expr);
- case FFECOM_f2ccodeCHARPTR:
- *type = build_pointer_type (DEFAULT_SIGNED_CHAR
- ? signed_char_type_node
- : unsigned_char_type_node);
- break;
+ ffecom_prepare_end ();
- case FFECOM_f2ccodeFLOAT:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
- layout_type (*type);
- break;
+ expand_return (ffecom_modify (NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ ffecom_expr (expr)));
+ }
- case FFECOM_f2ccodeDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
+ clear_momentary ();
+ }
- case FFECOM_f2ccodeLONGDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
+ ffecom_end_compstmt ();
- case FFECOM_f2ccodeTWOREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
- break;
+ func = current_function_decl;
+ finish_function (1);
- case FFECOM_f2ccodeTWODOUBLEREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
- break;
+ pop_f_function_context ();
- default:
- assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
- *type = error_mark_node;
- return;
- }
+ resume_momentary (yes);
- pushdecl (build_decl (TYPE_DECL,
- ffecom_get_invented_identifier ("__g77_f2c_%s",
- name, 0),
- *type));
+ recurse = FALSE;
+
+ lineno = old_lineno;
+ input_filename = old_input_filename;
+
+ ffecom_nested_entry_ = NULL;
+
+ return func;
}
#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-/* Set the f2c list-directed-I/O code for whatever (integral) type has the
- given size. */
-static void
-ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
- int code)
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static const char *
+ffecom_gfrt_args_ (ffecomGfrt ix)
{
- int j;
- tree t;
+ return ffecom_gfrt_argstring_[ix];
+}
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
- && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
- {
- assert (code != -1);
- ffecom_f2c_typecode_[bt][j] = code;
- code = -1;
- }
+#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_gfrt_tree_ (ffecomGfrt ix)
+{
+ if (ffecom_gfrt_[ix] == NULL_TREE)
+ ffecom_make_gfrt_ (ix);
+
+ return ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
+ ffecom_gfrt_[ix]);
}
#endif
-/* Finish up globals after doing all program units in file
-
- Need to handle only uninitialized COMMON areas. */
+/* Return initialize-to-zero expression for this VAR_DECL. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffeglobal
-ffecom_finish_global_ (ffeglobal global)
+static tree
+ffecom_init_zero_ (tree decl)
{
- tree cbtype;
- tree cbt;
- tree size;
-
- if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
- return global;
-
- if (ffeglobal_common_init (global))
- return global;
+ tree init;
+ int incremental = TREE_STATIC (decl);
+ tree type = TREE_TYPE (decl);
- cbt = ffeglobal_hook (global);
- if ((cbt == NULL_TREE)
- || !ffeglobal_common_have_size (global))
- return global; /* No need to make common, never ref'd. */
+ if (incremental)
+ {
+ int momentary = suspend_momentary ();
+ push_obstacks_nochange ();
+ if (TREE_PERMANENT (decl))
+ end_temporary_allocation ();
+ make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
+ assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
+ pop_obstacks ();
+ resume_momentary (momentary);
+ }
- suspend_momentary ();
+ push_momentary ();
- DECL_EXTERNAL (cbt) = 0;
+ if ((TREE_CODE (type) != ARRAY_TYPE)
+ && (TREE_CODE (type) != RECORD_TYPE)
+ && (TREE_CODE (type) != UNION_TYPE)
+ && !incremental)
+ init = convert (type, integer_zero_node);
+ else if (!incremental)
+ {
+ int momentary = suspend_momentary ();
- /* Give the array a size now. */
+ init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
+ TREE_CONSTANT (init) = 1;
+ TREE_STATIC (init) = 1;
- size = build_int_2 ((ffeglobal_common_size (global)
- + ffeglobal_common_pad (global)) - 1,
- 0);
+ resume_momentary (momentary);
+ }
+ else
+ {
+ int momentary = suspend_momentary ();
- 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);
+ assemble_zeros (int_size_in_bytes (type));
+ init = error_mark_node;
- cbt = start_decl (cbt, FALSE);
- assert (cbt == ffeglobal_hook (global));
+ resume_momentary (momentary);
+ }
- finish_decl (cbt, NULL_TREE, FALSE);
+ pop_momentary_nofree ();
- return global;
+ return init;
}
#endif
-/* Finish up any untransformed symbols. */
-
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_finish_symbol_transform_ (ffesymbol s)
+static tree
+ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
+ tree *maybe_tree)
{
- if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
- return s;
-
- /* It's easy to know to transform an untransformed symbol, to make sure
- we put out debugging info for it. But COMMON variables, unlike
- EQUIVALENCE ones, aren't given declarations in addition to the
- tree expressions that specify offsets, because COMMON variables
- can be referenced in the outer scope where only dummy arguments
- (PARM_DECLs) should really be seen. To be safe, just don't do any
- VAR_DECLs for COMMON variables when we transform them for real
- use, and therefore we do all the VAR_DECL creating here. */
+ tree expr_tree;
+ tree length_tree;
- if (ffesymbol_hook (s).decl_tree == NULL_TREE)
+ switch (ffebld_op (arg))
{
- if (ffesymbol_kind (s) != FFEINFO_kindNONE
- || (ffesymbol_where (s) != FFEINFO_whereNONE
- && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
- && ffesymbol_where (s) != FFEINFO_whereDUMMY))
- /* Not transformed, and not CHARACTER*(*), and not a dummy
- argument, which can happen only if the entry point names
- it "rides in on" are all invalidated for other reasons. */
- s = ffecom_sym_transform_ (s);
- }
+ case FFEBLD_opCONTER: /* For F90, check 0-length. */
+ if (ffetarget_length_character1
+ (ffebld_constant_character1
+ (ffebld_conter (arg))) == 0)
+ {
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
+ }
- if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
- && (ffesymbol_hook (s).decl_tree != error_mark_node))
- {
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
- int yes = suspend_momentary ();
+ *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;
- /* This isn't working, at least for dbxout. The .s file looks
- okay to me (burley), but in gdb 4.9 at least, the variables
- appear to reside somewhere outside of the common area, so
- it doesn't make sense to mislead anyone by generating the info
- on those variables until this is fixed. NOTE: Same problem
- with EQUIVALENCE, sadly...see similar #if later. */
- ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
- ffesymbol_storage (s));
+ case FFEBLD_opSYMTER:
+ case FFEBLD_opARRAYREF:
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opSUBSTR:
+ ffecom_char_args_ (&expr_tree, &length_tree, arg);
- resume_momentary (yes);
-#endif
- }
+ if ((expr_tree == error_mark_node)
+ || (length_tree == error_mark_node))
+ {
+ *maybe_tree = error_mark_node;
+ return error_mark_node;
+ }
- return s;
+ if (integer_zerop (length_tree))
+ {
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
+ }
+
+ expr_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
+ expr_tree);
+ expr_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
+ expr_tree,
+ integer_one_node);
+ expr_tree = convert (tree_type, expr_tree);
+
+ if (TREE_CODE (length_tree) == INTEGER_CST)
+ *maybe_tree = integer_one_node;
+ else /* Must check length at run time. */
+ *maybe_tree
+ = ffecom_truth_value
+ (ffecom_2 (GT_EXPR, integer_type_node,
+ length_tree,
+ ffecom_f2c_ftnlen_zero_node));
+ return expr_tree;
+
+ case FFEBLD_opPAREN:
+ case FFEBLD_opCONVERT:
+ if (ffeinfo_size (ffebld_info (arg)) == 0)
+ {
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
+ }
+ return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
+ maybe_tree);
+
+ case FFEBLD_opCONCATENATE:
+ {
+ tree maybe_left;
+ tree maybe_right;
+ tree expr_left;
+ tree expr_right;
+
+ expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
+ &maybe_left);
+ expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
+ &maybe_right);
+ *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
+ maybe_left,
+ maybe_right);
+ expr_tree = ffecom_3 (COND_EXPR, tree_type,
+ maybe_left,
+ expr_left,
+ expr_right);
+ return expr_tree;
+ }
+
+ default:
+ assert ("bad op in ICHAR" == NULL);
+ return error_mark_node;
+ }
}
#endif
-/* Append underscore(s) to name before calling get_identifier. "us"
- is nonzero if the name already contains an underscore and thus
- needs two underscores appended. */
+/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
+
+ tree length_arg;
+ ffebld expr;
+ length_arg = ffecom_intrinsic_len_ (expr);
+
+ Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
+ subexpressions by constructing the appropriate tree for the
+ length-of-character-text argument in a calling sequence. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_get_appended_identifier_ (char us, const char *name)
+ffecom_intrinsic_len_ (ffebld expr)
{
- int i;
- char *newname;
- tree id;
+ ffetargetCharacter1 val;
+ tree length;
+
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opCONTER:
+ val = ffebld_constant_character1 (ffebld_conter (expr));
+ length = build_int_2 (ffetarget_length_character1 (val), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ break;
+
+ case FFEBLD_opSYMTER:
+ {
+ ffesymbol s = ffebld_symter (expr);
+ tree item;
+
+ item = ffesymbol_hook (s).decl_tree;
+ if (item == NULL_TREE)
+ {
+ s = ffecom_sym_transform_ (s);
+ item = ffesymbol_hook (s).decl_tree;
+ }
+ if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
+ {
+ if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
+ length = ffesymbol_hook (s).length_tree;
+ else
+ {
+ length = build_int_2 (ffesymbol_size (s), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ }
+ }
+ else if (item == error_mark_node)
+ length = error_mark_node;
+ else /* FFEINFO_kindFUNCTION: */
+ length = NULL_TREE;
+ }
+ break;
- 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);
+ case FFEBLD_opARRAYREF:
+ length = ffecom_intrinsic_len_ (ffebld_left (expr));
+ break;
- free (newname);
+ case FFEBLD_opSUBSTR:
+ {
+ ffebld start;
+ ffebld end;
+ ffebld thing = ffebld_right (expr);
+ tree start_tree;
+ tree end_tree;
- return id;
-}
+ assert (ffebld_op (thing) == FFEBLD_opITEM);
+ start = ffebld_head (thing);
+ thing = ffebld_trail (thing);
+ assert (ffebld_trail (thing) == NULL);
+ end = ffebld_head (thing);
-#endif
-/* Decide whether to append underscore to name before calling
- get_identifier. */
+ length = ffecom_intrinsic_len_ (ffebld_left (expr));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_get_external_identifier_ (ffesymbol s)
-{
- char us;
- const char *name = ffesymbol_text (s);
+ if (length == error_mark_node)
+ break;
- /* If name is a built-in name, just return it as is. */
+ 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 (!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);
+ if (start_tree == error_mark_node)
+ {
+ length = error_mark_node;
+ break;
+ }
- us = ffe_is_second_underscore ()
- ? (strchr (name, '_') != NULL)
- : 0;
+ 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));
- return ffecom_get_appended_identifier_ (us, name);
-}
+ if (end_tree == error_mark_node)
+ {
+ length = error_mark_node;
+ break;
+ }
-#endif
-/* Decide whether to append underscore to internal name before calling
- get_identifier.
+ 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;
- This is for non-external, top-function-context names only. Transform
- identifier so it doesn't conflict with the transformed result
- of using a _different_ external name. E.g. if "CALL FOO" is
- transformed into "FOO_();", then the variable in "FOO_ = 3"
- must be transformed into something that does not conflict, since
- these two things should be independent.
+ 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;
- The transformation is as follows. If the name does not contain
- an underscore, there is no possible conflict, so just return.
- If the name does contain an underscore, then transform it just
- like we transform an external identifier. */
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opCONVERT:
+ length = build_int_2 (ffebld_size (expr), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ break;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_get_identifier_ (const char *name)
-{
- /* If name does not contain an underscore, just return it as is. */
+ default:
+ assert ("bad op for single char arg expr" == NULL);
+ length = ffecom_f2c_ftnlen_zero_node;
+ break;
+ }
- if (!ffe_is_underscoring ()
- || (strchr (name, '_') == NULL))
- return get_identifier (name);
+ assert (length != NULL_TREE);
- return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
- name);
+ return length;
}
#endif
-/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
-
- tree t;
- ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
- t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
- ffesymbol_kindtype(s));
+/* Handle CHARACTER assignments.
- Call after setting up containing function and getting trees for all
- other symbols. */
+ Generates code to do the assignment. Used by ordinary assignment
+ statement handler ffecom_let_stmt and by statement-function
+ handler to generate code for a statement function. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
+static void
+ffecom_let_char_ (tree dest_tree, tree dest_length,
+ ffetargetCharacterSize dest_size, ffebld source)
{
- ffebld expr = ffesymbol_sfexpr (s);
- tree type;
- tree func;
- tree result;
- bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
- static bool recurse = FALSE;
- int yes;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ ffecomConcatList_ catlist;
+ tree source_length;
+ tree source_tree;
+ tree expr_tree;
- ffecom_nested_entry_ = s;
+ if ((dest_tree == error_mark_node)
+ || (dest_length == error_mark_node))
+ return;
- /* For now, we don't have a handy pointer to where the sfunc is actually
- defined, though that should be easy to add to an ffesymbol. (The
- token/where info available might well point to the place where the type
- of the sfunc is declared, especially if that precedes the place where
- the sfunc itself is defined, which is typically the case.) We should
- put out a null pointer rather than point somewhere wrong, but I want to
- see how it works at this point. */
+ assert (dest_tree != NULL_TREE);
+ assert (dest_length != NULL_TREE);
- input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
+ /* Source might be an opCONVERT, which just means it is a different size
+ than the destination. Since the underlying implementation here handles
+ that (directly or via the s_copy or s_cat run-time-library functions),
+ we don't need the "convenience" of an opCONVERT that tells us to
+ truncate or blank-pad, particularly since the resulting implementation
+ would probably be slower than otherwise. */
- /* Pretransform the expression so any newly discovered things belong to the
- outer program unit, not to the statement function. */
+ while (ffebld_op (source) == FFEBLD_opCONVERT)
+ source = ffebld_left (source);
- ffecom_expr_transform_ (expr);
+ catlist = ffecom_concat_list_new_ (source, dest_size);
+ switch (ffecom_concat_list_count_ (catlist))
+ {
+ case 0: /* Shouldn't happen, but in case it does... */
+ ffecom_concat_list_kill_ (catlist);
+ source_tree = null_pointer_node;
+ source_length = ffecom_f2c_ftnlen_zero_node;
+ expr_tree = build_tree_list (NULL_TREE, dest_tree);
+ TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
+ TREE_CHAIN (TREE_CHAIN (expr_tree))
+ = build_tree_list (NULL_TREE, dest_length);
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
+ = build_tree_list (NULL_TREE, source_length);
- /* Make sure no recursive invocation of this fn (a specific case of failing
- to pretransform an sfunc's expression, i.e. where its expression
- references another untransformed sfunc) happens. */
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
- assert (!recurse);
- recurse = TRUE;
+ expand_expr_stmt (expr_tree);
- yes = suspend_momentary ();
+ return;
- push_f_function_context ();
+ case 1: /* The (fairly) easy case. */
+ ffecom_char_args_ (&source_tree, &source_length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ ffecom_concat_list_kill_ (catlist);
+ assert (source_tree != NULL_TREE);
+ assert (source_length != NULL_TREE);
+
+ if ((source_tree == error_mark_node)
+ || (source_length == error_mark_node))
+ return;
+
+ if (dest_size == 1)
+ {
+ dest_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (dest_tree))),
+ dest_tree);
+ dest_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (dest_tree))),
+ dest_tree,
+ integer_one_node);
+ source_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (source_tree))),
+ source_tree);
+ source_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (source_tree))),
+ source_tree,
+ integer_one_node);
- ffecom_push_calltemps ();
+ expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
- if (charfunc)
- type = void_type_node;
- else
- {
- type = ffecom_tree_type[bt][kt];
- if (type == NULL_TREE)
- type = integer_type_node; /* _sym_exec_transition reports
- error. */
- }
+ expand_expr_stmt (expr_tree);
- start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
- build_function_type (type, NULL_TREE),
- 1, /* nested/inline */
- 0); /* TREE_PUBLIC */
+ return;
+ }
- /* We don't worry about COMPLEX return values here, because this is
- entirely internal to our code, and gcc has the ability to return COMPLEX
- directly as a value. */
+ 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);
- yes = suspend_momentary ();
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
- if (charfunc)
- { /* Prepend arg for where result goes. */
- tree type;
+ expand_expr_stmt (expr_tree);
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
+ return;
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ default: /* Must actually concatenate things. */
+ break;
+ }
- ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
+ /* Heavy-duty concatenation. */
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
+ {
+ int count = ffecom_concat_list_count_ (catlist);
+ int i;
+ tree lengths;
+ tree items;
+ tree length_array;
+ tree item_array;
+ tree citem;
+ tree clength;
- push_parm_decl (result);
+#ifdef HOHO
+ length_array
+ = lengths
+ = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
+ FFETARGET_charactersizeNONE, count, TRUE);
+ item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
+ FFETARGET_charactersizeNONE,
+ count, TRUE);
+#else
+ {
+ 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);
}
- else
- result = NULL_TREE; /* Not ref'd if !charfunc. */
-
- ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
-
- resume_momentary (yes);
+#endif
- store_parm_decls (0);
+ 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;
+ }
- ffecom_start_compstmt_ ();
+ 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);
+ }
- if (expr != NULL)
- {
- if (charfunc)
- {
- ffetargetCharacterSize sz = ffesymbol_size (s);
- tree result_length;
+ 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);
- result_length = build_int_2 (sz, 0);
- TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
- ffecom_let_char_ (result, result_length, sz, expr);
- expand_null_return ();
- }
- else
- expand_return (ffecom_modify (NULL_TREE,
- DECL_RESULT (current_function_decl),
- ffecom_expr (expr)));
+ expand_expr_stmt (expr_tree);
+ }
- clear_momentary ();
- }
+ ffecom_concat_list_kill_ (catlist);
+}
- ffecom_end_compstmt_ ();
+#endif
+/* ffecom_make_gfrt_ -- Make initial info for run-time routine
- func = current_function_decl;
- finish_function (1);
+ ffecomGfrt ix;
+ ffecom_make_gfrt_(ix);
- ffecom_pop_calltemps ();
+ Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
+ for the indicated run-time routine (ix). */
- pop_f_function_context ();
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_make_gfrt_ (ffecomGfrt ix)
+{
+ tree t;
+ tree ttype;
- resume_momentary (yes);
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- recurse = FALSE;
+ switch (ffecom_gfrt_type_[ix])
+ {
+ case FFECOM_rttypeVOID_:
+ ttype = void_type_node;
+ break;
- lineno = old_lineno;
- input_filename = old_input_filename;
+ case FFECOM_rttypeVOIDSTAR_:
+ ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
+ break;
- ffecom_nested_entry_ = NULL;
+ case FFECOM_rttypeFTNINT_:
+ ttype = ffecom_f2c_ftnint_type_node;
+ break;
- return func;
-}
+ case FFECOM_rttypeINTEGER_:
+ ttype = ffecom_f2c_integer_type_node;
+ break;
-#endif
+ case FFECOM_rttypeLONGINT_:
+ ttype = ffecom_f2c_longint_type_node;
+ break;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static const char *
-ffecom_gfrt_args_ (ffecomGfrt ix)
-{
- return ffecom_gfrt_argstring_[ix];
-}
+ case FFECOM_rttypeLOGICAL_:
+ ttype = ffecom_f2c_logical_type_node;
+ break;
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_gfrt_tree_ (ffecomGfrt ix)
-{
- if (ffecom_gfrt_[ix] == NULL_TREE)
- ffecom_make_gfrt_ (ix);
+ case FFECOM_rttypeREAL_F2C_:
+ ttype = double_type_node;
+ break;
- return ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
- ffecom_gfrt_[ix]);
-}
+ case FFECOM_rttypeREAL_GNU_:
+ ttype = float_type_node;
+ break;
-#endif
-/* Return initialize-to-zero expression for this VAR_DECL. */
+ case FFECOM_rttypeCOMPLEX_F2C_:
+ ttype = void_type_node;
+ break;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_init_zero_ (tree decl)
-{
- tree init;
- int incremental = TREE_STATIC (decl);
- tree type = TREE_TYPE (decl);
+ case FFECOM_rttypeCOMPLEX_GNU_:
+ ttype = ffecom_f2c_complex_type_node;
+ break;
- if (incremental)
- {
- int momentary = suspend_momentary ();
- push_obstacks_nochange ();
- if (TREE_PERMANENT (decl))
- end_temporary_allocation ();
- make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
- assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- pop_obstacks ();
- resume_momentary (momentary);
- }
+ case FFECOM_rttypeDOUBLE_:
+ ttype = double_type_node;
+ break;
- push_momentary ();
+ case FFECOM_rttypeDOUBLEREAL_:
+ ttype = ffecom_f2c_doublereal_type_node;
+ break;
- if ((TREE_CODE (type) != ARRAY_TYPE)
- && (TREE_CODE (type) != RECORD_TYPE)
- && (TREE_CODE (type) != UNION_TYPE)
- && !incremental)
- init = convert (type, integer_zero_node);
- else if (!incremental)
- {
- int momentary = suspend_momentary ();
+ case FFECOM_rttypeDBLCMPLX_F2C_:
+ ttype = void_type_node;
+ break;
- init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
- TREE_CONSTANT (init) = 1;
- TREE_STATIC (init) = 1;
+ case FFECOM_rttypeDBLCMPLX_GNU_:
+ ttype = ffecom_f2c_doublecomplex_type_node;
+ break;
- resume_momentary (momentary);
+ case FFECOM_rttypeCHARACTER_:
+ ttype = void_type_node;
+ break;
+
+ default:
+ ttype = NULL;
+ assert ("bad rttype" == NULL);
+ break;
}
- else
- {
- int momentary = suspend_momentary ();
- assemble_zeros (int_size_in_bytes (type));
- init = error_mark_node;
+ ttype = build_function_type (ttype, NULL_TREE);
+ t = build_decl (FUNCTION_DECL,
+ get_identifier (ffecom_gfrt_name_[ix]),
+ ttype);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
+ TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
- resume_momentary (momentary);
- }
+ t = start_decl (t, TRUE);
- pop_momentary_nofree ();
+ finish_decl (t, NULL_TREE, TRUE);
- return init;
+ resume_temporary_allocation ();
+ pop_obstacks ();
+
+ ffecom_gfrt_[ix] = t;
}
#endif
+/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
+
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
- tree *maybe_tree)
+static void
+ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
{
- tree expr_tree;
- tree length_tree;
+ ffesymbol s = ffestorag_symbol (st);
- switch (ffebld_op (arg))
- {
- case FFEBLD_opCONTER: /* For F90, check 0-length. */
- if (ffetarget_length_character1
- (ffebld_constant_character1
- (ffebld_conter (arg))) == 0)
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
+ if (ffesymbol_namelisted (s))
+ ffecom_member_namelisted_ = TRUE;
+}
- *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;
+#endif
+/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
+ the member so debugger will see it. Otherwise nobody should be
+ referencing the member. */
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBSTR:
- ffecom_push_calltemps ();
- ffecom_char_args_ (&expr_tree, &length_tree, arg);
- ffecom_pop_calltemps ();
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
+static void
+ffecom_member_phase2_ (ffestorag mst, ffestorag st)
+{
+ ffesymbol s;
+ tree t;
+ tree mt;
+ tree type;
- if ((expr_tree == error_mark_node)
- || (length_tree == error_mark_node))
- {
- *maybe_tree = error_mark_node;
- return error_mark_node;
- }
+ if ((mst == NULL)
+ || ((mt = ffestorag_hook (mst)) == NULL)
+ || (mt == error_mark_node))
+ return;
- if (integer_zerop (length_tree))
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
+ if ((st == NULL)
+ || ((s = ffestorag_symbol (st)) == NULL))
+ return;
- 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);
+ type = ffecom_type_localvar_ (s,
+ ffesymbol_basictype (s),
+ ffesymbol_kindtype (s));
+ if (type == error_mark_node)
+ return;
- if (TREE_CODE (length_tree) == INTEGER_CST)
- *maybe_tree = integer_one_node;
- else /* Must check length at run time. */
- *maybe_tree
- = ffecom_truth_value
- (ffecom_2 (GT_EXPR, integer_type_node,
- length_tree,
- ffecom_f2c_ftnlen_zero_node));
- return expr_tree;
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ type);
- 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);
+ TREE_STATIC (t) = TREE_STATIC (mt);
+ DECL_INITIAL (t) = NULL_TREE;
+ TREE_ASM_WRITTEN (t) = 1;
- case FFEBLD_opCONCATENATE:
- {
- tree maybe_left;
- tree maybe_right;
- tree expr_left;
- tree expr_right;
+ 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)));
- 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;
- }
+ t = start_decl (t, FALSE);
- default:
- assert ("bad op in ICHAR" == NULL);
- return error_mark_node;
- }
+ finish_decl (t, NULL_TREE, FALSE);
}
#endif
-/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
-
- tree length_arg;
- ffebld expr;
- length_arg = ffecom_intrinsic_len_ (expr);
-
- Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
- subexpressions by constructing the appropriate tree for the
- length-of-character-text argument in a calling sequence. */
+#endif
+/* Prepare source expression for assignment into a destination perhaps known
+ to be of a specific size. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_intrinsic_len_ (ffebld expr)
+static void
+ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
{
- 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;
+ ffecomConcatList_ catlist;
+ int count;
+ int i;
+ tree ltmp;
+ tree itmp;
+ tree tempvar = NULL_TREE;
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
- {
- if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
- length = ffesymbol_hook (s).length_tree;
- else
- {
- length = build_int_2 (ffesymbol_size (s), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- }
- }
- else if (item == error_mark_node)
- length = error_mark_node;
- else /* FFEINFO_kindFUNCTION: */
- length = NULL_TREE;
- }
- break;
+ while (ffebld_op (source) == FFEBLD_opCONVERT)
+ source = ffebld_left (source);
- case FFEBLD_opARRAYREF:
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
- break;
+ catlist = ffecom_concat_list_new_ (source, dest_size);
+ count = ffecom_concat_list_count_ (catlist);
- case FFEBLD_opSUBSTR:
- {
- ffebld start;
- ffebld end;
- ffebld thing = ffebld_right (expr);
- tree start_tree;
- tree end_tree;
+ 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;
+ }
- assert (ffebld_op (thing) == FFEBLD_opITEM);
- start = ffebld_head (thing);
- thing = ffebld_trail (thing);
- assert (ffebld_trail (thing) == NULL);
- end = ffebld_head (thing);
+ for (i = 0; i < count; ++i)
+ ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
+ ffecom_concat_list_kill_ (catlist);
- if (length == error_mark_node)
- break;
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (source, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+}
- 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));
+/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
- if (start_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
+ Ignores STAR (alternate-return) dummies. All other get exec-transitioned
+ (which generates their trees) and then their trees get push_parm_decl'd.
- 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));
+ The second arg is TRUE if the dummies are for a statement function, in
+ which case lengths are not pushed for character arguments (since they are
+ always known by both the caller and the callee, though the code allows
+ for someday permitting CHAR*(*) stmtfunc dummies). */
- if (end_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
+{
+ ffebld dummy;
+ ffebld dumlist;
+ ffesymbol s;
+ tree parm;
- 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;
+ ffecom_transform_only_dummies_ = TRUE;
- 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;
+ /* First push the parms corresponding to actual dummy "contents". */
- case FFEBLD_opFUNCREF:
- case FFEBLD_opCONVERT:
- length = build_int_2 (ffebld_size (expr), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- break;
+ for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
+ {
+ dummy = ffebld_head (dumlist);
+ switch (ffebld_op (dummy))
+ {
+ case FFEBLD_opSTAR:
+ case FFEBLD_opANY:
+ continue; /* Forget alternate returns. */
- default:
- assert ("bad op for single char arg expr" == NULL);
- length = ffecom_f2c_ftnlen_zero_node;
- break;
+ 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);
}
- assert (length != NULL_TREE);
+ /* Then, for CHARACTER dummies, push the parms giving their lengths. */
- return length;
+ for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
+ {
+ dummy = ffebld_head (dumlist);
+ switch (ffebld_op (dummy))
+ {
+ case FFEBLD_opSTAR:
+ case FFEBLD_opANY:
+ continue; /* Forget alternate returns, they mean
+ NOTHING! */
+
+ default:
+ break;
+ }
+ s = ffebld_symter (dummy);
+ if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
+ continue; /* Only looking for CHARACTER arguments. */
+ if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
+ continue; /* Stmtfunc arg with known size needs no
+ length param. */
+ if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
+ continue; /* Only looking for variables and arrays. */
+ parm = ffesymbol_hook (s).length_tree;
+ assert (parm != NULL_TREE);
+ if (parm != error_mark_node)
+ push_parm_decl (parm);
+ }
+
+ ffecom_transform_only_dummies_ = FALSE;
}
#endif
-/* ffecom_let_char_ -- Do assignment stuff for character type
-
- tree dest_tree; // destination (ADDR_EXPR)
- tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
- ffetargetCharacterSize dest_size; // length
- ffebld source; // source expression
- ffecom_let_char_(dest_tree,dest_length,dest_size,source);
+/* ffecom_start_progunit_ -- Beginning of program unit
- Generates code to do the assignment. Used by ordinary assignment
- statement handler ffecom_let_stmt and by statement-function
- handler to generate code for a statement function. */
+ Does GNU back end stuff necessary to teach it about the start of its
+ equivalent of a Fortran program unit. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffecom_let_char_ (tree dest_tree, tree dest_length,
- ffetargetCharacterSize dest_size, ffebld source)
+ffecom_start_progunit_ ()
{
- ffecomConcatList_ catlist;
- tree source_length;
- tree source_tree;
- tree expr_tree;
+ ffesymbol fn = ffecom_primary_entry_;
+ ffebld arglist;
+ tree id; /* Identifier (name) of function. */
+ tree type; /* Type of function. */
+ tree result; /* Result of function. */
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffeglobal g;
+ ffeglobalType gt;
+ ffeglobalType egt = FFEGLOBAL_type;
+ bool charfunc;
+ bool cmplxfunc;
+ bool altentries = (ffecom_num_entrypoints_ != 0);
+ bool multi
+ = altentries
+ && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
+ && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
+ bool main_program = FALSE;
+ int old_lineno = lineno;
+ char *old_input_filename = input_filename;
+ int yes;
- if ((dest_tree == error_mark_node)
- || (dest_length == error_mark_node))
- return;
+ assert (fn != NULL);
+ assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
- assert (dest_tree != NULL_TREE);
- assert (dest_length != NULL_TREE);
+ input_filename = ffesymbol_where_filename (fn);
+ lineno = ffesymbol_where_filelinenum (fn);
- /* Source might be an opCONVERT, which just means it is a different size
- than the destination. Since the underlying implementation here handles
- that (directly or via the s_copy or s_cat run-time-library functions),
- we don't need the "convenience" of an opCONVERT that tells us to
- truncate or blank-pad, particularly since the resulting implementation
- would probably be slower than otherwise. */
+ /* c-parse.y indeed does call suspend_momentary and not only ignores the
+ return value, but also never calls resume_momentary, when starting an
+ outer function (see "fndef:", "setspecs:", and so on). So g77 does the
+ same thing. It shouldn't be a problem since start_function calls
+ temporary_allocation, but it might be necessary. If it causes a problem
+ here, then maybe there's a bug lurking in gcc. NOTE: This identical
+ comment appears twice in thist file. */
+
+ suspend_momentary ();
+
+ switch (ffecom_primary_entry_kind_)
+ {
+ case FFEINFO_kindPROGRAM:
+ main_program = TRUE;
+ gt = FFEGLOBAL_typeMAIN;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
+
+ case FFEINFO_kindBLOCKDATA:
+ gt = FFEGLOBAL_typeBDATA;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
+
+ case FFEINFO_kindFUNCTION:
+ gt = FFEGLOBAL_typeFUNC;
+ egt = FFEGLOBAL_typeEXT;
+ bt = ffesymbol_basictype (fn);
+ kt = ffesymbol_kindtype (fn);
+ if (bt == FFEINFO_basictypeNONE)
+ {
+ ffeimplic_establish_symbol (fn);
+ if (ffesymbol_funcresult (fn) != NULL)
+ ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
+ bt = ffesymbol_basictype (fn);
+ kt = ffesymbol_kindtype (fn);
+ }
+
+ if (multi)
+ charfunc = cmplxfunc = FALSE;
+ else if (bt == FFEINFO_basictypeCHARACTER)
+ charfunc = TRUE, cmplxfunc = FALSE;
+ else if ((bt == FFEINFO_basictypeCOMPLEX)
+ && ffesymbol_is_f2c (fn)
+ && !altentries)
+ charfunc = FALSE, cmplxfunc = TRUE;
+ else
+ charfunc = cmplxfunc = FALSE;
+
+ if (multi || charfunc)
+ type = ffecom_tree_fun_type_void;
+ else if (ffesymbol_is_f2c (fn) && !altentries)
+ type = ffecom_tree_fun_type[bt][kt];
+ else
+ type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
+
+ if ((type == NULL_TREE)
+ || (TREE_TYPE (type) == NULL_TREE))
+ type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
+ break;
+
+ case FFEINFO_kindSUBROUTINE:
+ gt = FFEGLOBAL_typeSUBR;
+ egt = FFEGLOBAL_typeEXT;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ if (ffecom_is_altreturning_)
+ type = ffecom_tree_subr_type;
+ else
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
- while (ffebld_op (source) == FFEBLD_opCONVERT)
- source = ffebld_left (source);
+ default:
+ assert ("say what??" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindANY:
+ gt = FFEGLOBAL_typeANY;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = error_mark_node;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
+ }
- catlist = ffecom_concat_list_new_ (source, dest_size);
- switch (ffecom_concat_list_count_ (catlist))
+ if (altentries)
{
- case 0: /* Shouldn't happen, but in case it does... */
- ffecom_concat_list_kill_ (catlist);
- source_tree = null_pointer_node;
- source_length = ffecom_f2c_ftnlen_zero_node;
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE, dest_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list (NULL_TREE, source_length);
+ id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
+ ffesymbol_text (fn),
+ -1);
+ }
+#if FFETARGET_isENFORCED_MAIN
+ else if (main_program)
+ id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
+#endif
+ else
+ id = ffecom_get_external_identifier_ (fn);
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
+ start_function (id,
+ type,
+ 0, /* nested/inline */
+ !altentries); /* TREE_PUBLIC */
- expand_expr_stmt (expr_tree);
+ TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
- return;
+ if (!altentries
+ && ((g = ffesymbol_global (fn)) != NULL)
+ && ((ffeglobal_type (g) == gt)
+ || (ffeglobal_type (g) == egt)))
+ {
+ ffeglobal_set_hook (g, current_function_decl);
+ }
- case 1: /* The (fairly) easy case. */
- ffecom_char_args_ (&source_tree, &source_length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (source_tree != NULL_TREE);
- assert (source_length != NULL_TREE);
+ yes = suspend_momentary ();
- if ((source_tree == error_mark_node)
- || (source_length == error_mark_node))
- return;
+ /* Arg handling needs exec-transitioned ffesymbols to work with. But
+ exec-transitioning needs current_function_decl to be filled in. So we
+ do these things in two phases. */
- if (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);
+ if (altentries)
+ { /* 1st arg identifies which entrypoint. */
+ ffecom_which_entrypoint_decl_
+ = build_decl (PARM_DECL,
+ ffecom_get_invented_identifier ("__g77_%s",
+ "which_entrypoint",
+ -1),
+ integer_type_node);
+ push_parm_decl (ffecom_which_entrypoint_decl_);
+ }
- expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
+ if (charfunc
+ || cmplxfunc
+ || multi)
+ { /* Arg for result (return value). */
+ tree type;
+ tree length;
- expand_expr_stmt (expr_tree);
+ 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_;
- return;
- }
+ result = ffecom_get_invented_identifier ("__g77_%s",
+ "result", -1);
- 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);
+ /* Make length arg _and_ enhance type info for CHAR arg itself. */
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
+ if (charfunc)
+ length = ffecom_char_enhance_arg_ (&type, fn);
+ else
+ length = NULL_TREE; /* Not ref'd if !charfunc. */
- expand_expr_stmt (expr_tree);
+ type = build_pointer_type (type);
+ result = build_decl (PARM_DECL, result, type);
- return;
+ push_parm_decl (result);
+ if (multi)
+ ffecom_multi_retval_ = result;
+ else
+ ffecom_func_result_ = result;
- default: /* Must actually concatenate things. */
- break;
+ if (charfunc)
+ {
+ push_parm_decl (length);
+ ffecom_func_length_ = length;
+ }
}
- /* Heavy-duty concatenation. */
-
- {
- int count = ffecom_concat_list_count_ (catlist);
- int i;
- tree lengths;
- tree items;
- tree length_array;
- tree item_array;
- tree citem;
- tree clength;
-
- length_array
- = lengths
- = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
- item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE,
- count, TRUE);
+ if (ffecom_primary_entry_is_proc_)
+ {
+ if (altentries)
+ arglist = ffecom_master_arglist_;
+ else
+ arglist = ffesymbol_dummyargs (fn);
+ ffecom_push_dummy_decls_ (arglist, FALSE);
+ }
- 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;
- }
+ resume_momentary (yes);
- 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);
- }
+ if (TREE_CODE (current_function_decl) != ERROR_MARK)
+ store_parm_decls (main_program ? 1 : 0);
- 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);
+ ffecom_start_compstmt ();
+ /* Disallow temp vars at this level. */
+ current_binding_level->prep_state = 2;
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
+ lineno = old_lineno;
+ input_filename = old_input_filename;
- expand_expr_stmt (expr_tree);
- }
+ /* This handles any symbols still untransformed, in case -g specified.
+ This used to be done in ffecom_finish_progunit, but it turns out to
+ be necessary to do it here so that statement functions are
+ expanded before code. But don't bother for BLOCK DATA. */
- ffecom_concat_list_kill_ (catlist);
+ if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
+ ffesymbol_drive (ffecom_finish_symbol_transform_);
}
#endif
-/* ffecom_make_gfrt_ -- Make initial info for run-time routine
+/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
- ffecomGfrt ix;
- ffecom_make_gfrt_(ix);
+ ffesymbol s;
+ ffecom_sym_transform_(s);
+
+ The ffesymbol_hook info for s is updated with appropriate backend info
+ on the symbol. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffesymbol
+ffecom_sym_transform_ (ffesymbol s)
+{
+ tree t; /* Transformed thingy. */
+ tree tlen; /* Length if CHAR*(*). */
+ bool addr; /* Is t the address of the thingy? */
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffeglobal g;
+ int yes;
+ int old_lineno = lineno;
+ char *old_input_filename = input_filename;
- Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
- for the indicated run-time routine (ix). */
+ /* Must ensure special ASSIGN variables are declared at top of outermost
+ block, else they'll end up in the innermost block when their first
+ ASSIGN is seen, which leaves them out of scope when they're the
+ subject of a GOTO or I/O statement.
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_make_gfrt_ (ffecomGfrt ix)
-{
- tree t;
- tree ttype;
+ We make this variable even if -fugly-assign. Just let it go unused,
+ in case it turns out there are cases where we really want to use this
+ variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ if (! ffecom_transform_only_dummies_
+ && ffesymbol_assigned (s)
+ && ! ffesymbol_hook (s).assign_tree)
+ s = ffecom_sym_transform_assign_ (s);
- switch (ffecom_gfrt_type_[ix])
+ if (ffesymbol_sfdummyparent (s) == NULL)
{
- case FFECOM_rttypeVOID_:
- ttype = void_type_node;
- break;
+ input_filename = ffesymbol_where_filename (s);
+ lineno = ffesymbol_where_filelinenum (s);
+ }
+ else
+ {
+ ffesymbol sf = ffesymbol_sfdummyparent (s);
- case FFECOM_rttypeVOIDSTAR_:
- ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
- break;
+ input_filename = ffesymbol_where_filename (sf);
+ lineno = ffesymbol_where_filelinenum (sf);
+ }
- case FFECOM_rttypeFTNINT_:
- ttype = ffecom_f2c_ftnint_type_node;
- break;
+ bt = ffeinfo_basictype (ffebld_info (s));
+ kt = ffeinfo_kindtype (ffebld_info (s));
- case FFECOM_rttypeINTEGER_:
- ttype = ffecom_f2c_integer_type_node;
- break;
+ t = NULL_TREE;
+ tlen = NULL_TREE;
+ addr = FALSE;
- case FFECOM_rttypeLONGINT_:
- ttype = ffecom_f2c_longint_type_node;
- break;
+ switch (ffesymbol_kind (s))
+ {
+ case FFEINFO_kindNONE:
+ switch (ffesymbol_where (s))
+ {
+ case FFEINFO_whereDUMMY: /* Subroutine or function. */
+ assert (ffecom_transform_only_dummies_);
- case FFECOM_rttypeLOGICAL_:
- ttype = ffecom_f2c_logical_type_node;
- break;
+ /* Before 0.4, this could be ENTITY/DUMMY, but see
+ ffestu_sym_end_transition -- no longer true (in particular, if
+ it could be an ENTITY, it _will_ be made one, so that
+ possibility won't come through here). So we never make length
+ arg for CHARACTER type. */
- case FFECOM_rttypeREAL_F2C_:
- ttype = double_type_node;
- break;
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_ptr_to_subr_type);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
+#endif
+ addr = TRUE;
+ break;
- case FFECOM_rttypeREAL_GNU_:
- ttype = float_type_node;
- break;
+ case FFEINFO_whereGLOBAL: /* Subroutine or function. */
+ assert (!ffecom_transform_only_dummies_);
- case FFECOM_rttypeCOMPLEX_F2C_:
- ttype = void_type_node;
- break;
+ 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;
+ }
- case FFECOM_rttypeCOMPLEX_GNU_:
- ttype = ffecom_f2c_complex_type_node;
- break;
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- case FFECOM_rttypeDOUBLE_:
- ttype = double_type_node;
- break;
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_subr_type); /* Assume subr. */
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- case FFECOM_rttypeDOUBLEREAL_:
- ttype = ffecom_f2c_doublereal_type_node;
- break;
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- case FFECOM_rttypeDBLCMPLX_F2C_:
- ttype = void_type_node;
- break;
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
- case FFECOM_rttypeDBLCMPLX_GNU_:
- ttype = ffecom_f2c_doublecomplex_type_node;
- break;
+ resume_temporary_allocation ();
+ pop_obstacks ();
- case FFECOM_rttypeCHARACTER_:
- ttype = void_type_node;
- break;
+ break;
- default:
- ttype = NULL;
- assert ("bad rttype" == NULL);
+ default:
+ assert ("NONE where unexpected" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ break;
+ }
break;
- }
- ttype = build_function_type (ttype, NULL_TREE);
- t = build_decl (FUNCTION_DECL,
- get_identifier (ffecom_gfrt_name_[ix]),
- ttype);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
- TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
+ case FFEINFO_kindENTITY:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
- t = start_decl (t, TRUE);
+ case FFEINFO_whereCONSTANT:
+ /* ~~Debugging info needed? */
+ assert (!ffecom_transform_only_dummies_);
+ t = error_mark_node; /* Shouldn't ever see this in expr. */
+ break;
- finish_decl (t, NULL_TREE, TRUE);
+ case FFEINFO_whereLOCAL:
+ assert (!ffecom_transform_only_dummies_);
- resume_temporary_allocation ();
- pop_obstacks ();
+ {
+ ffestorag st = ffesymbol_storage (s);
+ tree type;
- ffecom_gfrt_[ix] = t;
-}
+ if ((st != NULL)
+ && (ffestorag_size (st) == 0))
+ {
+ t = error_mark_node;
+ break;
+ }
-#endif
-/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
+ yes = suspend_momentary ();
+ type = ffecom_type_localvar_ (s, bt, kt);
+ resume_momentary (yes);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
-{
- ffesymbol s = ffestorag_symbol (st);
+ if (type == error_mark_node)
+ {
+ t = error_mark_node;
+ break;
+ }
- if (ffesymbol_namelisted (s))
- ffecom_member_namelisted_ = TRUE;
-}
+ if ((st != NULL)
+ && (ffestorag_parent (st) != NULL))
+ { /* Child of EQUIVALENCE parent. */
+ ffestorag est;
+ tree et;
+ int yes;
+ ffetargetOffset offset;
-#endif
-/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
- the member so debugger will see it. Otherwise nobody should be
- referencing the member. */
+ est = ffestorag_parent (st);
+ ffecom_transform_equiv_ (est);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
-static void
-ffecom_member_phase2_ (ffestorag mst, ffestorag st)
-{
- ffesymbol s;
- tree t;
- tree mt;
- tree type;
+ et = ffestorag_hook (est);
+ assert (et != NULL_TREE);
- if ((mst == NULL)
- || ((mt = ffestorag_hook (mst)) == NULL)
- || (mt == error_mark_node))
- return;
+ if (! TREE_STATIC (et))
+ put_var_into_stack (et);
- if ((st == NULL)
- || ((s = ffestorag_symbol (st)) == NULL))
- return;
+ yes = suspend_momentary ();
- type = ffecom_type_localvar_ (s,
- ffesymbol_basictype (s),
- ffesymbol_kindtype (s));
- if (type == error_mark_node)
- return;
+ offset = ffestorag_modulo (est)
+ + ffestorag_offset (ffesymbol_storage (s))
+ - ffestorag_offset (est);
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
+ ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
- TREE_STATIC (t) = TREE_STATIC (mt);
- DECL_INITIAL (t) = NULL_TREE;
- TREE_ASM_WRITTEN (t) = 1;
+ /* (t_type *) (((char *) &et) + offset) */
- 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 = convert (string_type_node, /* (char *) */
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (et)),
+ et));
+ t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
+ t,
+ build_int_2 (offset, 0));
+ t = convert (build_pointer_type (type),
+ t);
- t = start_decl (t, FALSE);
+ addr = TRUE;
- finish_decl (t, NULL_TREE, FALSE);
-}
+ resume_momentary (yes);
+ }
+ else
+ {
+ tree initexpr;
+ bool init = ffesymbol_is_init (s);
-#endif
-#endif
-/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
+ yes = suspend_momentary ();
- Ignores STAR (alternate-return) dummies. All other get exec-transitioned
- (which generates their trees) and then their trees get push_parm_decl'd.
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ type);
- The second arg is TRUE if the dummies are for a statement function, in
- which case lengths are not pushed for character arguments (since they are
- always known by both the caller and the callee, though the code allows
- for someday permitting CHAR*(*) stmtfunc dummies). */
+ if (init
+ || ffesymbol_namelisted (s)
+#ifdef FFECOM_sizeMAXSTACKITEM
+ || ((st != NULL)
+ && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
+#endif
+ || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
+ && (ffecom_primary_entry_kind_
+ != FFEINFO_kindBLOCKDATA)
+ && (ffesymbol_is_save (s) || ffe_is_saveall ())))
+ TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
+ else
+ TREE_STATIC (t) = 0; /* No need to make static. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
-{
- ffebld dummy;
- ffebld dumlist;
- ffesymbol s;
- tree parm;
+ if (init || ffe_is_init_local_zero ())
+ DECL_INITIAL (t) = error_mark_node;
- ffecom_transform_only_dummies_ = TRUE;
+ /* Keep -Wunused from complaining about var if it
+ is used as sfunc arg or DATA implied-DO. */
+ if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
+ DECL_IN_SYSTEM_HEADER (t) = 1;
- /* First push the parms corresponding to actual dummy "contents". */
+ t = start_decl (t, FALSE);
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
- {
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns. */
+ if (init)
+ {
+ if (ffesymbol_init (s) != NULL)
+ initexpr = ffecom_expr (ffesymbol_init (s));
+ else
+ initexpr = ffecom_init_zero_ (t);
+ }
+ else if (ffe_is_init_local_zero ())
+ initexpr = ffecom_init_zero_ (t);
+ else
+ initexpr = NULL_TREE; /* Not ref'd if !init. */
- 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);
- }
+ finish_decl (t, initexpr, FALSE);
- /* Then, for CHARACTER dummies, push the parms giving their lengths. */
+ if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
+ {
+ tree size_tree;
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
- {
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns, they mean
- NOTHING! */
+ size_tree = size_binop (CEIL_DIV_EXPR,
+ DECL_SIZE (t),
+ size_int (BITS_PER_UNIT));
+ assert (TREE_INT_CST_HIGH (size_tree) == 0);
+ assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
+ }
- default:
+ resume_momentary (yes);
+ }
+ }
break;
- }
- s = ffebld_symter (dummy);
- if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
- continue; /* Only looking for CHARACTER arguments. */
- if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
- continue; /* Stmtfunc arg with known size needs no
- length param. */
- if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
- continue; /* Only looking for variables and arrays. */
- parm = ffesymbol_hook (s).length_tree;
- assert (parm != NULL_TREE);
- if (parm != error_mark_node)
- push_parm_decl (parm);
- }
-
- ffecom_transform_only_dummies_ = FALSE;
-}
-#endif
-/* ffecom_start_progunit_ -- Beginning of program unit
+ case FFEINFO_whereRESULT:
+ assert (!ffecom_transform_only_dummies_);
- Does GNU back end stuff necessary to teach it about the start of its
- equivalent of a Fortran program unit. */
+ if (bt == FFEINFO_basictypeCHARACTER)
+ { /* Result is already in list of dummies, use
+ it (& length). */
+ t = ffecom_func_result_;
+ tlen = ffecom_func_length_;
+ addr = TRUE;
+ break;
+ }
+ if ((ffecom_num_entrypoints_ == 0)
+ && (bt == FFEINFO_basictypeCOMPLEX)
+ && (ffesymbol_is_f2c (ffecom_primary_entry_)))
+ { /* Result is already in list of dummies, use
+ it. */
+ t = ffecom_func_result_;
+ addr = TRUE;
+ break;
+ }
+ if (ffecom_func_result_ != NULL_TREE)
+ {
+ t = ffecom_func_result_;
+ break;
+ }
+ if ((ffecom_num_entrypoints_ != 0)
+ && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
+ {
+ yes = suspend_momentary ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_start_progunit_ ()
-{
- ffesymbol fn = ffecom_primary_entry_;
- ffebld arglist;
- tree id; /* Identifier (name) of function. */
- tree type; /* Type of function. */
- tree result; /* Result of function. */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- ffeglobalType gt;
- ffeglobalType egt = FFEGLOBAL_type;
- bool charfunc;
- bool cmplxfunc;
- bool altentries = (ffecom_num_entrypoints_ != 0);
- bool multi
- = altentries
- && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
- bool main_program = FALSE;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
- int yes;
+ assert (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]);
- assert (fn != NULL);
- assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
+ resume_momentary (yes);
+ break;
+ }
- input_filename = ffesymbol_where_filename (fn);
- lineno = ffesymbol_where_filelinenum (fn);
+ yes = suspend_momentary ();
- /* c-parse.y indeed does call suspend_momentary and not only ignores the
- return value, but also never calls resume_momentary, when starting an
- outer function (see "fndef:", "setspecs:", and so on). So g77 does the
- same thing. It shouldn't be a problem since start_function calls
- temporary_allocation, but it might be necessary. If it causes a problem
- here, then maybe there's a bug lurking in gcc. NOTE: This identical
- comment appears twice in thist file. */
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_type[bt][kt]);
+ TREE_STATIC (t) = 0; /* Put result on stack. */
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- suspend_momentary ();
+ ffecom_func_result_ = t;
- 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;
+ resume_momentary (yes);
+ 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_whereDUMMY:
+ {
+ tree type;
+ ffebld dl;
+ ffebld dim;
+ tree low;
+ tree high;
+ tree old_sizes;
+ bool adjustable = FALSE; /* Conditionally adjustable? */
- 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);
- }
+ type = ffecom_tree_type[bt][kt];
+ if (ffesymbol_sfdummyparent (s) != NULL)
+ {
+ if (current_function_decl == ffecom_outer_function_decl_)
+ { /* Exec transition before sfunc
+ context; get it later. */
+ break;
+ }
+ t = ffecom_get_identifier_ (ffesymbol_text
+ (ffesymbol_sfdummyparent (s)));
+ }
+ else
+ t = ffecom_get_identifier_ (ffesymbol_text (s));
- 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;
+ assert (ffecom_transform_only_dummies_);
- 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);
+ old_sizes = get_pending_sizes ();
+ put_pending_sizes (old_sizes);
- if ((type == NULL_TREE)
- || (TREE_TYPE (type) == NULL_TREE))
- type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
- break;
+ if (bt == FFEINFO_basictypeCHARACTER)
+ tlen = ffecom_char_enhance_arg_ (&type, s);
+ type = ffecom_check_size_overflow_ (s, type, TRUE);
- 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;
+ for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
+ {
+ if (type == error_mark_node)
+ break;
- default:
- assert ("say what??" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- gt = FFEGLOBAL_typeANY;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = error_mark_node;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
- }
+ dim = ffebld_head (dl);
+ assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
+ if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
+ low = ffecom_integer_one_node;
+ else
+ low = ffecom_expr (ffebld_left (dim));
+ assert (ffebld_right (dim) != NULL);
+ if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
+ || ffecom_doing_entry_)
+ {
+ /* Used to just do high=low. But for ffecom_tree_
+ canonize_ref_, it probably is important to correctly
+ assess the size. E.g. given COMPLEX C(*),CFUNC and
+ C(2)=CFUNC(C), overlap can happen, while it can't
+ for, say, C(1)=CFUNC(C(2)). */
+ /* Even more recently used to set to INT_MAX, but that
+ broke when some overflow checking went into the back
+ end. Now we just leave the upper bound unspecified. */
+ high = NULL;
+ }
+ else
+ high = ffecom_expr (ffebld_right (dim));
- if (altentries)
- {
- id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
- ffesymbol_text (fn),
- 0);
- }
-#if FFETARGET_isENFORCED_MAIN
- else if (main_program)
- id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
-#endif
- else
- id = ffecom_get_external_identifier_ (fn);
+ /* Determine whether array is conditionally adjustable,
+ to decide whether back-end magic is needed.
- start_function (id,
- type,
- 0, /* nested/inline */
- !altentries); /* TREE_PUBLIC */
+ Normally the front end uses the back-end function
+ variable_size to wrap SAVE_EXPR's around expressions
+ affecting the size/shape of an array so that the
+ size/shape info doesn't change during execution
+ of the compiled code even though variables and
+ functions referenced in those expressions might.
- TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
+ variable_size also makes sure those saved expressions
+ get evaluated immediately upon entry to the
+ compiled procedure -- the front end normally doesn't
+ have to worry about that.
- if (!altentries
- && ((g = ffesymbol_global (fn)) != NULL)
- && ((ffeglobal_type (g) == gt)
- || (ffeglobal_type (g) == egt)))
- {
- ffeglobal_set_hook (g, current_function_decl);
- }
+ However, there is a problem with this that affects
+ g77's implementation of entry points, and that is
+ that it is _not_ true that each invocation of the
+ compiled procedure is permitted to evaluate
+ array size/shape info -- because it is possible
+ that, for some invocations, that info is invalid (in
+ which case it is "promised" -- i.e. a violation of
+ the Fortran standard -- that the compiled code
+ won't reference the array or its size/shape
+ during that particular invocation).
- yes = suspend_momentary ();
+ To phrase this in C terms, consider this gcc function:
- /* Arg handling needs exec-transitioned ffesymbols to work with. But
- exec-transitioning needs current_function_decl to be filled in. So we
- do these things in two phases. */
+ void foo (int *n, float (*a)[*n])
+ {
+ // a is "pointer to array ...", fyi.
+ }
- if (altentries)
- { /* 1st arg identifies which entrypoint. */
- ffecom_which_entrypoint_decl_
- = build_decl (PARM_DECL,
- ffecom_get_invented_identifier ("__g77_%s",
- "which_entrypoint",
- 0),
- integer_type_node);
- push_parm_decl (ffecom_which_entrypoint_decl_);
- }
+ Suppose that, for some invocations, it is permitted
+ for a caller of foo to do this:
- if (charfunc
- || cmplxfunc
- || multi)
- { /* Arg for result (return value). */
- tree type;
- tree length;
+ foo (NULL, NULL);
- 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_;
+ Now the _written_ code for foo can take such a call
+ into account by either testing explicitly for whether
+ (a == NULL) || (n == NULL) -- presumably it is
+ not permitted to reference *a in various fashions
+ if (n == NULL) I suppose -- or it can avoid it by
+ looking at other info (other arguments, static/global
+ data, etc.).
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ However, this won't work in gcc 2.5.8 because it'll
+ automatically emit the code to save the "*n"
+ expression, which'll yield a NULL dereference for
+ the "foo (NULL, NULL)" call, something the code
+ for foo cannot prevent.
- /* Make length arg _and_ enhance type info for CHAR arg itself. */
+ g77 definitely needs to avoid executing such
+ code anytime the pointer to the adjustable array
+ is NULL, because even if its bounds expressions
+ don't have any references to possible "absent"
+ variables like "*n" -- say all variable references
+ are to COMMON variables, i.e. global (though in C,
+ local static could actually make sense) -- the
+ expressions could yield other run-time problems
+ for allowably "dead" values in those variables.
- if (charfunc)
- length = ffecom_char_enhance_arg_ (&type, fn);
- else
- length = NULL_TREE; /* Not ref'd if !charfunc. */
+ For example, let's consider a more complicated
+ version of foo:
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
+ extern int i;
+ extern int j;
- push_parm_decl (result);
- if (multi)
- ffecom_multi_retval_ = result;
- else
- ffecom_func_result_ = result;
+ void foo (float (*a)[i/j])
+ {
+ ...
+ }
- if (charfunc)
- {
- push_parm_decl (length);
- ffecom_func_length_ = length;
- }
- }
+ The above is (essentially) quite valid for Fortran
+ but, again, for a call like "foo (NULL);", it is
+ permitted for i and j to be undefined when the
+ call is made. If j happened to be zero, for
+ example, emitting the code to evaluate "i/j"
+ could result in a run-time error.
- if (ffecom_primary_entry_is_proc_)
- {
- if (altentries)
- arglist = ffecom_master_arglist_;
- else
- arglist = ffesymbol_dummyargs (fn);
- ffecom_push_dummy_decls_ (arglist, FALSE);
- }
+ Offhand, though I don't have my F77 or F90
+ standards handy, it might even be valid for a
+ bounds expression to contain a function reference,
+ in which case I doubt it is permitted for an
+ implementation to invoke that function in the
+ Fortran case involved here (invocation of an
+ alternate ENTRY point that doesn't have the adjustable
+ array as one of its arguments).
- resume_momentary (yes);
+ So, the code that the compiler would normally emit
+ to preevaluate the size/shape info for an
+ adjustable array _must not_ be executed at run time
+ in certain cases. Specifically, for Fortran,
+ the case is when the pointer to the adjustable
+ array == NULL. (For gnu-ish C, it might be nice
+ for the source code itself to specify an expression
+ that, if TRUE, inhibits execution of the code. Or
+ reverse the sense for elegance.)
- if (TREE_CODE (current_function_decl) != ERROR_MARK)
- store_parm_decls (main_program ? 1 : 0);
+ (Note that g77 could use a different test than NULL,
+ actually, since it happens to always pass an
+ integer to the called function that specifies which
+ entry point is being invoked. Hmm, this might
+ solve the next problem.)
+
+ One way a user could, I suppose, write "foo" so
+ it works is to insert COND_EXPR's for the
+ size/shape info so the dangerous stuff isn't
+ actually done, as in:
+
+ void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
+ {
+ ...
+ }
- ffecom_start_compstmt_ ();
+ The next problem is that the front end needs to
+ be able to tell the back end about the array's
+ decl _before_ it tells it about the conditional
+ expression to inhibit evaluation of size/shape info,
+ as shown above.
- lineno = old_lineno;
- input_filename = old_input_filename;
+ To solve this, the front end needs to be able
+ to give the back end the expression to inhibit
+ generation of the preevaluation code _after_
+ it makes the decl for the adjustable array.
- /* This handles any symbols still untransformed, in case -g specified.
- This used to be done in ffecom_finish_progunit, but it turns out to
- be necessary to do it here so that statement functions are
- expanded before code. But don't bother for BLOCK DATA. */
+ Until then, the above example using the COND_EXPR
+ doesn't pass muster with gcc because the "(a == NULL)"
+ part has a reference to "a", which is still
+ undefined at that point.
- if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
- ffesymbol_drive (ffecom_finish_symbol_transform_);
-}
+ g77 will therefore use a different mechanism in the
+ meantime. */
-#endif
-/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
+ if (!adjustable
+ && ((TREE_CODE (low) != INTEGER_CST)
+ || (high && TREE_CODE (high) != INTEGER_CST)))
+ adjustable = TRUE;
- ffesymbol s;
- ffecom_sym_transform_(s);
+#if 0 /* Old approach -- see below. */
+ if (TREE_CODE (low) != INTEGER_CST)
+ low = ffecom_3 (COND_EXPR, integer_type_node,
+ ffecom_adjarray_passed_ (s),
+ low,
+ ffecom_integer_zero_node);
- The ffesymbol_hook info for s is updated with appropriate backend info
- on the symbol. */
+ 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 FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_sym_transform_ (ffesymbol s)
-{
- tree t; /* Transformed thingy. */
- tree tlen; /* Length if CHAR*(*). */
- bool addr; /* Is t the address of the thingy? */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- int yes;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ /* ~~~gcc/stor-layout.c (layout_type) should do this,
+ probably. Fixes 950302-1.f. */
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
- }
- else
- {
- ffesymbol sf = ffesymbol_sfdummyparent (s);
+ if (TREE_CODE (low) != INTEGER_CST)
+ low = variable_size (low);
- input_filename = ffesymbol_where_filename (sf);
- lineno = ffesymbol_where_filelinenum (sf);
- }
+ /* ~~~Similarly, this fixes dumb0.f. The C front end
+ does this, which is why dumb0.c would work. */
- bt = ffeinfo_basictype (ffebld_info (s));
- kt = ffeinfo_kindtype (ffebld_info (s));
+ if (high && TREE_CODE (high) != INTEGER_CST)
+ high = variable_size (high);
- t = NULL_TREE;
- tlen = NULL_TREE;
- addr = FALSE;
+ type
+ = build_array_type
+ (type,
+ build_range_type (ffecom_integer_type_node,
+ low, high));
+ type = ffecom_check_size_overflow_ (s, type, TRUE);
+ }
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindNONE:
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereDUMMY: /* Subroutine or function. */
- assert (ffecom_transform_only_dummies_);
+ if (type == error_mark_node)
+ {
+ t = error_mark_node;
+ break;
+ }
- /* Before 0.4, this could be ENTITY/DUMMY, but see
- ffestu_sym_end_transition -- no longer true (in particular, if
- it could be an ENTITY, it _will_ be made one, so that
- possibility won't come through here). So we never make length
- arg for CHARACTER type. */
+ if ((ffesymbol_sfdummyparent (s) == NULL)
+ || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
+ {
+ type = build_pointer_type (type);
+ addr = TRUE;
+ }
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
+ t = build_decl (PARM_DECL, t, type);
#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
+ DECL_ARTIFICIAL (t) = 1;
#endif
- addr = TRUE;
- break;
- case FFEINFO_whereGLOBAL: /* Subroutine or function. */
- assert (!ffecom_transform_only_dummies_);
+ /* If this arg is present in every entry point's list of
+ dummy args, then we're done. */
- 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);
+ if (ffesymbol_numentries (s)
+ == (ffecom_num_entrypoints_ + 1))
break;
- }
- push_obstacks_nochange ();
- end_temporary_allocation ();
+#if 1
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type); /* Assume subr. */
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
+ /* If variable_size in stor-layout has been called during
+ the above, then get_pending_sizes should have the
+ yet-to-be-evaluated saved expressions pending.
+ Make the whole lot of them get emitted, conditionally
+ on whether the array decl ("t" above) is not NULL. */
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ {
+ tree sizes = get_pending_sizes ();
+ tree tem;
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
+ for (tem = sizes;
+ tem != old_sizes;
+ tem = TREE_CHAIN (tem))
+ {
+ tree temv = TREE_VALUE (tem);
- resume_temporary_allocation ();
- pop_obstacks ();
+ if (sizes == tem)
+ sizes = temv;
+ else
+ sizes
+ = ffecom_2 (COMPOUND_EXPR,
+ TREE_TYPE (sizes),
+ temv,
+ sizes);
+ }
- break;
+ 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);
- default:
- assert ("NONE where unexpected" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- break;
- }
- break;
+ sizes
+ = tree_cons (NULL_TREE, sizes, tem);
+ }
- case FFEINFO_kindENTITY:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
+ if (sizes)
+ put_pending_sizes (sizes);
+ }
- case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */
- assert (!ffecom_transform_only_dummies_);
- t = error_mark_node; /* Shouldn't ever see this in expr. */
+#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_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
-
+ case FFEINFO_whereCOMMON:
{
+ ffesymbol cs;
+ ffeglobal cg;
+ tree ct;
ffestorag st = ffesymbol_storage (s);
tree type;
+ int yes;
- if ((st != NULL)
- && (ffestorag_size (st) == 0))
- {
- t = error_mark_node;
- break;
- }
-
- yes = suspend_momentary ();
- type = ffecom_type_localvar_ (s, bt, kt);
- resume_momentary (yes);
-
- if (type == error_mark_node)
+ cs = ffesymbol_common (s); /* The COMMON area itself. */
+ if (st != NULL) /* Else not laid out. */
{
- t = error_mark_node;
- break;
+ ffecom_transform_common_ (cs);
+ st = ffesymbol_storage (s);
}
- if ((st != NULL)
- && (ffestorag_parent (st) != NULL))
- { /* Child of EQUIVALENCE parent. */
- ffestorag est;
- tree et;
- int yes;
- ffetargetOffset offset;
+ yes = suspend_momentary ();
- est = ffestorag_parent (st);
- ffecom_transform_equiv_ (est);
+ type = ffecom_type_localvar_ (s, bt, kt);
- et = ffestorag_hook (est);
- assert (et != NULL_TREE);
+ cg = ffesymbol_global (cs); /* The global COMMON info. */
+ if ((cg == NULL)
+ || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
+ ct = NULL_TREE;
+ else
+ ct = ffeglobal_hook (cg); /* The common area's tree. */
- if (! TREE_STATIC (et))
- put_var_into_stack (et);
+ if ((ct == NULL_TREE)
+ || (st == NULL)
+ || (type == error_mark_node))
+ t = error_mark_node;
+ else
+ {
+ ffetargetOffset offset;
+ ffestorag cst;
- yes = suspend_momentary ();
+ cst = ffestorag_parent (st);
+ assert (cst == ffesymbol_storage (cs));
- offset = ffestorag_modulo (est)
- + ffestorag_offset (ffesymbol_storage (s))
- - ffestorag_offset (est);
+ offset = ffestorag_modulo (cst)
+ + ffestorag_offset (st)
+ - ffestorag_offset (cst);
- ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
+ ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
- /* (t_type *) (((char *) &et) + offset) */
+ /* (t_type *) (((char *) &ct) + offset) */
t = convert (string_type_node, /* (char *) */
ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (et)),
- et));
+ build_pointer_type (TREE_TYPE (ct)),
+ ct));
t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
t,
build_int_2 (offset, 0));
t);
addr = TRUE;
-
- resume_momentary (yes);
}
- else
- {
- tree initexpr;
- bool init = ffesymbol_is_init (s);
-
- yes = suspend_momentary ();
-
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
-
- if (init
- || ffesymbol_namelisted (s)
-#ifdef FFECOM_sizeMAXSTACKITEM
- || ((st != NULL)
- && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
-#endif
- || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_
- != FFEINFO_kindBLOCKDATA)
- && (ffesymbol_is_save (s) || ffe_is_saveall ())))
- TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
- else
- TREE_STATIC (t) = 0; /* No need to make static. */
-
- if (init || ffe_is_init_local_zero ())
- DECL_INITIAL (t) = error_mark_node;
-
- /* Keep -Wunused from complaining about var if it
- is used as sfunc arg or DATA implied-DO. */
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
- DECL_IN_SYSTEM_HEADER (t) = 1;
-
- t = start_decl (t, FALSE);
-
- if (init)
- {
- if (ffesymbol_init (s) != NULL)
- initexpr = ffecom_expr (ffesymbol_init (s));
- else
- initexpr = ffecom_init_zero_ (t);
- }
- else if (ffe_is_init_local_zero ())
- initexpr = ffecom_init_zero_ (t);
- else
- initexpr = NULL_TREE; /* Not ref'd if !init. */
-
- finish_decl (t, initexpr, FALSE);
- if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
- {
- tree size_tree;
+ resume_momentary (yes);
+ }
+ break;
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (t),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
- }
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("ENTITY where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- resume_momentary (yes);
- }
- }
+ case FFEINFO_kindFUNCTION:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
break;
- case FFEINFO_whereRESULT:
+ case FFEINFO_whereGLOBAL:
assert (!ffecom_transform_only_dummies_);
- if (bt == FFEINFO_basictypeCHARACTER)
- { /* Result is already in list of dummies, use
- it (& length). */
- t = ffecom_func_result_;
- tlen = ffecom_func_length_;
- addr = TRUE;
- break;
- }
- if ((ffecom_num_entrypoints_ == 0)
- && (bt == FFEINFO_basictypeCOMPLEX)
- && (ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Result is already in list of dummies, use
- it. */
- t = ffecom_func_result_;
- addr = TRUE;
- break;
- }
- if (ffecom_func_result_ != NULL_TREE)
+ 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 = ffecom_func_result_;
+ t = ffeglobal_hook (g);
break;
}
- if ((ffecom_num_entrypoints_ != 0)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
- {
- yes = suspend_momentary ();
- assert (ffecom_multi_retval_ != NULL_TREE);
- t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
- ffecom_multi_retval_);
- t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
- t, ffecom_multi_fields_[bt][kt]);
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- resume_momentary (yes);
- 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);
- yes = suspend_momentary ();
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ t);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_type[bt][kt]);
- TREE_STATIC (t) = 0; /* Put result on stack. */
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- ffecom_func_result_ = t;
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
+
+ resume_temporary_allocation ();
+ pop_obstacks ();
- resume_momentary (yes);
break;
case FFEINFO_whereDUMMY:
- {
- tree type;
- ffebld dl;
- ffebld dim;
- tree low;
- tree high;
- tree old_sizes;
- bool adjustable = FALSE; /* Conditionally adjustable? */
+ assert (ffecom_transform_only_dummies_);
- type = ffecom_tree_type[bt][kt];
- if (ffesymbol_sfdummyparent (s) != NULL)
- {
- if (current_function_decl == ffecom_outer_function_decl_)
- { /* Exec transition before sfunc
- context; get it later. */
- break;
- }
- t = ffecom_get_identifier_ (ffesymbol_text
- (ffesymbol_sfdummyparent (s)));
- }
- else
- t = ffecom_get_identifier_ (ffesymbol_text (s));
+ if (ffesymbol_is_f2c (s)
+ && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
+ t = ffecom_tree_ptr_to_fun_type[bt][kt];
+ else
+ t = build_pointer_type
+ (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
+
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ t);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
+#endif
+ addr = TRUE;
+ break;
+
+ case FFEINFO_whereCONSTANT: /* Statement function. */
+ assert (!ffecom_transform_only_dummies_);
+ t = ffecom_gen_sfuncdef_ (s, bt, kt);
+ break;
+
+ case FFEINFO_whereINTRINSIC:
+ assert (!ffecom_transform_only_dummies_);
+ break; /* Let actual references generate their
+ decls. */
+
+ default:
+ assert ("FUNCTION where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
+
+ case FFEINFO_kindSUBROUTINE:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- assert (ffecom_transform_only_dummies_);
+ case FFEINFO_whereGLOBAL:
+ assert (!ffecom_transform_only_dummies_);
- old_sizes = get_pending_sizes ();
- put_pending_sizes (old_sizes);
+ 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;
+ }
- if (bt == FFEINFO_basictypeCHARACTER)
- tlen = ffecom_char_enhance_arg_ (&type, s);
- type = ffecom_check_size_overflow_ (s, type, TRUE);
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
- {
- if (type == error_mark_node)
- break;
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_subr_type);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- dim = ffebld_head (dl);
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
- low = ffecom_integer_one_node;
- else
- low = ffecom_expr (ffebld_left (dim));
- assert (ffebld_right (dim) != NULL);
- if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
- || ffecom_doing_entry_)
- {
- /* Used to just do high=low. But for ffecom_tree_
- canonize_ref_, it probably is important to correctly
- assess the size. E.g. given COMPLEX C(*),CFUNC and
- C(2)=CFUNC(C), overlap can happen, while it can't
- for, say, C(1)=CFUNC(C(2)). */
- /* Even more recently used to set to INT_MAX, but that
- broke when some overflow checking went into the back
- end. Now we just leave the upper bound unspecified. */
- high = NULL;
- }
- else
- high = ffecom_expr (ffebld_right (dim));
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- /* Determine whether array is conditionally adjustable,
- to decide whether back-end magic is needed.
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
- Normally the front end uses the back-end function
- variable_size to wrap SAVE_EXPR's around expressions
- affecting the size/shape of an array so that the
- size/shape info doesn't change during execution
- of the compiled code even though variables and
- functions referenced in those expressions might.
+ resume_temporary_allocation ();
+ pop_obstacks ();
- variable_size also makes sure those saved expressions
- get evaluated immediately upon entry to the
- compiled procedure -- the front end normally doesn't
- have to worry about that.
+ break;
- However, there is a problem with this that affects
- g77's implementation of entry points, and that is
- that it is _not_ true that each invocation of the
- compiled procedure is permitted to evaluate
- array size/shape info -- because it is possible
- that, for some invocations, that info is invalid (in
- which case it is "promised" -- i.e. a violation of
- the Fortran standard -- that the compiled code
- won't reference the array or its size/shape
- during that particular invocation).
+ case FFEINFO_whereDUMMY:
+ assert (ffecom_transform_only_dummies_);
- To phrase this in C terms, consider this gcc function:
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_ptr_to_subr_type);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
+#endif
+ addr = TRUE;
+ break;
- void foo (int *n, float (*a)[*n])
- {
- // a is "pointer to array ...", fyi.
- }
+ case FFEINFO_whereINTRINSIC:
+ assert (!ffecom_transform_only_dummies_);
+ break; /* Let actual references generate their
+ decls. */
- Suppose that, for some invocations, it is permitted
- for a caller of foo to do this:
+ default:
+ assert ("SUBROUTINE where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- foo (NULL, NULL);
+ case FFEINFO_kindPROGRAM:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- Now the _written_ code for foo can take such a call
- into account by either testing explicitly for whether
- (a == NULL) || (n == NULL) -- presumably it is
- not permitted to reference *a in various fashions
- if (n == NULL) I suppose -- or it can avoid it by
- looking at other info (other arguments, static/global
- data, etc.).
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("PROGRAM where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- However, this won't work in gcc 2.5.8 because it'll
- automatically emit the code to save the "*n"
- expression, which'll yield a NULL dereference for
- the "foo (NULL, NULL)" call, something the code
- for foo cannot prevent.
+ case FFEINFO_kindBLOCKDATA:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- g77 definitely needs to avoid executing such
- code anytime the pointer to the adjustable array
- is NULL, because even if its bounds expressions
- don't have any references to possible "absent"
- variables like "*n" -- say all variable references
- are to COMMON variables, i.e. global (though in C,
- local static could actually make sense) -- the
- expressions could yield other run-time problems
- for allowably "dead" values in those variables.
+ case FFEINFO_whereGLOBAL:
+ assert (!ffecom_transform_only_dummies_);
- For example, let's consider a more complicated
- version of foo:
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- extern int i;
- extern int j;
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_blockdata_type);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- void foo (float (*a)[i/j])
- {
- ...
- }
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- The above is (essentially) quite valid for Fortran
- but, again, for a call like "foo (NULL);", it is
- permitted for i and j to be undefined when the
- call is made. If j happened to be zero, for
- example, emitting the code to evaluate "i/j"
- could result in a run-time error.
+ resume_temporary_allocation ();
+ pop_obstacks ();
- Offhand, though I don't have my F77 or F90
- standards handy, it might even be valid for a
- bounds expression to contain a function reference,
- in which case I doubt it is permitted for an
- implementation to invoke that function in the
- Fortran case involved here (invocation of an
- alternate ENTRY point that doesn't have the adjustable
- array as one of its arguments).
+ break;
- So, the code that the compiler would normally emit
- to preevaluate the size/shape info for an
- adjustable array _must not_ be executed at run time
- in certain cases. Specifically, for Fortran,
- the case is when the pointer to the adjustable
- array == NULL. (For gnu-ish C, it might be nice
- for the source code itself to specify an expression
- that, if TRUE, inhibits execution of the code. Or
- reverse the sense for elegance.)
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("BLOCKDATA where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- (Note that g77 could use a different test than NULL,
- actually, since it happens to always pass an
- integer to the called function that specifies which
- entry point is being invoked. Hmm, this might
- solve the next problem.)
+ case FFEINFO_kindCOMMON:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL:
+ assert (!ffecom_transform_only_dummies_);
+ ffecom_transform_common_ (s);
+ break;
+
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("COMMON where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- One way a user could, I suppose, write "foo" so
- it works is to insert COND_EXPR's for the
- size/shape info so the dangerous stuff isn't
- actually done, as in:
+ case FFEINFO_kindCONSTRUCT:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL:
+ assert (!ffecom_transform_only_dummies_);
+ break;
- void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
- {
- ...
- }
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("CONSTRUCT where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- The next problem is that the front end needs to
- be able to tell the back end about the array's
- decl _before_ it tells it about the conditional
- expression to inhibit evaluation of size/shape info,
- as shown above.
+ case FFEINFO_kindNAMELIST:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL:
+ assert (!ffecom_transform_only_dummies_);
+ t = ffecom_transform_namelist_ (s);
+ break;
- To solve this, the front end needs to be able
- to give the back end the expression to inhibit
- generation of the preevaluation code _after_
- it makes the decl for the adjustable array.
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("NAMELIST where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- Until then, the above example using the COND_EXPR
- doesn't pass muster with gcc because the "(a == NULL)"
- part has a reference to "a", which is still
- undefined at that point.
+ default:
+ assert ("kind unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindANY:
+ t = error_mark_node;
+ break;
+ }
- g77 will therefore use a different mechanism in the
- meantime. */
+ ffesymbol_hook (s).decl_tree = t;
+ ffesymbol_hook (s).length_tree = tlen;
+ ffesymbol_hook (s).addr = addr;
- if (!adjustable
- && ((TREE_CODE (low) != INTEGER_CST)
- || (high && TREE_CODE (high) != INTEGER_CST)))
- adjustable = TRUE;
+ lineno = old_lineno;
+ input_filename = old_input_filename;
-#if 0 /* Old approach -- see below. */
- if (TREE_CODE (low) != INTEGER_CST)
- low = ffecom_3 (COND_EXPR, integer_type_node,
- ffecom_adjarray_passed_ (s),
- low,
- ffecom_integer_zero_node);
+ return s;
+}
- 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
+/* Transform into ASSIGNable symbol.
- /* ~~~gcc/stor-layout.c/layout_type should do this,
- probably. Fixes 950302-1.f. */
-
- if (TREE_CODE (low) != INTEGER_CST)
- low = variable_size (low);
-
- /* ~~~similarly, this fixes dumb0.f. The C front end
- does this, which is why dumb0.c would work. */
-
- if (high && TREE_CODE (high) != INTEGER_CST)
- high = variable_size (high);
+ Symbol has already been transformed, but for whatever reason, the
+ resulting decl_tree has been deemed not usable for an ASSIGN target.
+ (E.g. it isn't wide enough to hold a pointer.) So, here we invent
+ another local symbol of type void * and stuff that in the assign_tree
+ argument. The F77/F90 standards allow this implementation. */
- type
- = build_array_type
- (type,
- build_range_type (ffecom_integer_type_node,
- low, high));
- type = ffecom_check_size_overflow_ (s, type, TRUE);
- }
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffesymbol
+ffecom_sym_transform_assign_ (ffesymbol s)
+{
+ tree t; /* Transformed thingy. */
+ int yes;
+ int old_lineno = lineno;
+ char *old_input_filename = input_filename;
- if (type == error_mark_node)
- {
- t = error_mark_node;
- break;
- }
+ if (ffesymbol_sfdummyparent (s) == NULL)
+ {
+ input_filename = ffesymbol_where_filename (s);
+ lineno = ffesymbol_where_filelinenum (s);
+ }
+ else
+ {
+ ffesymbol sf = ffesymbol_sfdummyparent (s);
- if ((ffesymbol_sfdummyparent (s) == NULL)
- || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
- {
- type = build_pointer_type (type);
- addr = TRUE;
- }
+ input_filename = ffesymbol_where_filename (sf);
+ lineno = ffesymbol_where_filelinenum (sf);
+ }
- t = build_decl (PARM_DECL, t, type);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
+ assert (!ffecom_transform_only_dummies_);
- /* If this arg is present in every entry point's list of
- dummy args, then we're done. */
+ yes = suspend_momentary ();
- if (ffesymbol_numentries (s)
- == (ffecom_num_entrypoints_ + 1))
- break;
+ t = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
+ ffesymbol_text (s),
+ -1),
+ TREE_TYPE (null_pointer_node));
-#if 1
+ switch (ffesymbol_where (s))
+ {
+ case FFEINFO_whereLOCAL:
+ /* Unlike for regular vars, SAVE status is easy to determine for
+ ASSIGNed vars, since there's no initialization, there's no
+ effective storage association (so "SAVE J" does not apply to
+ K even given "EQUIVALENCE (J,K)"), there's no size issue
+ to worry about, etc. */
+ if ((ffesymbol_is_save (s) || ffe_is_saveall ())
+ && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
+ && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
+ TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
+ else
+ TREE_STATIC (t) = 0; /* No need to make static. */
+ break;
- /* If variable_size in stor-layout has been called during
- the above, then get_pending_sizes should have the
- yet-to-be-evaluated saved expressions pending.
- Make the whole lot of them get emitted, conditionally
- on whether the array decl ("t" above) is not NULL. */
+ case FFEINFO_whereCOMMON:
+ TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
+ break;
- {
- tree sizes = get_pending_sizes ();
- tree tem;
+ case FFEINFO_whereDUMMY:
+ /* Note that twinning a DUMMY means the caller won't see
+ the ASSIGNed value. But both F77 and F90 allow implementations
+ to do this, i.e. disallow Fortran code that would try and
+ take advantage of actually putting a label into a variable
+ via a dummy argument (or any other storage association, for
+ that matter). */
+ TREE_STATIC (t) = 0;
+ break;
- for (tem = sizes;
- tem != old_sizes;
- tem = TREE_CHAIN (tem))
- {
- tree temv = TREE_VALUE (tem);
+ default:
+ TREE_STATIC (t) = 0;
+ break;
+ }
- if (sizes == tem)
- sizes = temv;
- else
- sizes
- = ffecom_2 (COMPOUND_EXPR,
- TREE_TYPE (sizes),
- temv,
- sizes);
- }
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- 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);
+ resume_momentary (yes);
- sizes
- = tree_cons (NULL_TREE, sizes, tem);
- }
+ ffesymbol_hook (s).assign_tree = t;
- if (sizes)
- put_pending_sizes (sizes);
- }
+ lineno = old_lineno;
+ input_filename = old_input_filename;
-#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;
+ return s;
+}
- case FFEINFO_whereCOMMON:
- {
- ffesymbol cs;
- ffeglobal cg;
- tree ct;
- ffestorag st = ffesymbol_storage (s);
- tree type;
- int yes;
+#endif
+/* Implement COMMON area in back end.
- cs = ffesymbol_common (s); /* The COMMON area itself. */
- if (st != NULL) /* Else not laid out. */
- {
- ffecom_transform_common_ (cs);
- st = ffesymbol_storage (s);
- }
+ Because COMMON-based variables can be referenced in the dimension
+ expressions of dummy (adjustable) arrays, and because dummies
+ (in the gcc back end) need to be put in the outer binding level
+ of a function (which has two binding levels, the outer holding
+ the dummies and the inner holding the other vars), special care
+ must be taken to handle COMMON areas.
- yes = suspend_momentary ();
+ The current strategy is basically to always tell the back end about
+ the COMMON area as a top-level external reference to just a block
+ of storage of the master type of that area (e.g. integer, real,
+ character, whatever -- not a structure). As a distinct action,
+ if initial values are provided, tell the back end about the area
+ as a top-level non-external (initialized) area and remember not to
+ allow further initialization or expansion of the area. Meanwhile,
+ if no initialization happens at all, tell the back end about
+ the largest size we've seen declared so the space does get reserved.
+ (This function doesn't handle all that stuff, but it does some
+ of the important things.)
- type = ffecom_type_localvar_ (s, bt, kt);
+ Meanwhile, for COMMON variables themselves, just keep creating
+ references like *((float *) (&common_area + offset)) each time
+ we reference the variable. In other words, don't make a VAR_DECL
+ or any kind of component reference (like we used to do before 0.4),
+ though we might do that as well just for debugging purposes (and
+ stuff the rtl with the appropriate offset expression). */
- cg = ffesymbol_global (cs); /* The global COMMON info. */
- if ((cg == NULL)
- || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
- ct = NULL_TREE;
- else
- ct = ffeglobal_hook (cg); /* The common area's tree. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_transform_common_ (ffesymbol s)
+{
+ ffestorag st = ffesymbol_storage (s);
+ ffeglobal g = ffesymbol_global (s);
+ tree cbt;
+ tree cbtype;
+ tree init;
+ tree high;
+ bool is_init = ffestorag_is_init (st);
- if ((ct == NULL_TREE)
- || (st == NULL)
- || (type == error_mark_node))
- t = error_mark_node;
- else
- {
- ffetargetOffset offset;
- ffestorag cst;
+ assert (st != NULL);
- cst = ffestorag_parent (st);
- assert (cst == ffesymbol_storage (cs));
+ if ((g == NULL)
+ || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
+ return;
- offset = ffestorag_modulo (cst)
- + ffestorag_offset (st)
- - ffestorag_offset (cst);
+ /* First update the size of the area in global terms. */
- ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
+ ffeglobal_size_common (s, ffestorag_size (st));
- /* (t_type *) (((char *) &ct) + offset) */
+ if (!ffeglobal_common_init (g))
+ is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
- t = convert (string_type_node, /* (char *) */
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ct)),
- ct));
- t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
- t,
- build_int_2 (offset, 0));
- t = convert (build_pointer_type (type),
- t);
+ cbt = ffeglobal_hook (g);
- addr = TRUE;
- }
+ /* If we already have declared this common block for a previous program
+ unit, and either we already initialized it or we don't have new
+ initialization for it, just return what we have without changing it. */
- resume_momentary (yes);
- }
- break;
+ if ((cbt != NULL_TREE)
+ && (!is_init
+ || !DECL_EXTERNAL (cbt)))
+ return;
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("ENTITY where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ /* Process inits. */
- case FFEINFO_kindFUNCTION:
- switch (ffeinfo_where (ffesymbol_info (s)))
+ if (is_init)
+ {
+ if (ffestorag_init (st) != NULL)
{
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
+ ffebld sexp;
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
+ /* Set the padding for the expression, so ffecom_expr
+ knows to insert that many zeros. */
+ switch (ffebld_op (sexp = ffestorag_init (st)))
{
- t = ffeglobal_hook (g);
+ case FFEBLD_opCONTER:
+ ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
break;
- }
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ case FFEBLD_opARRTER:
+ ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
+ 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);
+ case FFEBLD_opACCTER:
+ ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
+ break;
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- t);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
+ default:
+ assert ("bad op for cmn init (pad)" == NULL);
+ break;
+ }
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ init = ffecom_expr (sexp);
+ if (init == error_mark_node)
+ { /* Hopefully the back end complained! */
+ init = NULL_TREE;
+ if (cbt != NULL_TREE)
+ return;
+ }
+ }
+ else
+ init = error_mark_node;
+ }
+ else
+ init = NULL_TREE;
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- resume_temporary_allocation ();
- pop_obstacks ();
+ /* cbtype must be permanently allocated! */
- break;
+ /* Allocate the MAX of the areas so far, seen filewide. */
+ high = build_int_2 ((ffeglobal_common_size (g)
+ + ffeglobal_common_pad (g)) - 1, 0);
+ TREE_TYPE (high) = ffecom_integer_type_node;
- case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
+ 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 (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));
+ 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;
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- t);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
- addr = TRUE;
- break;
+ cbt = start_decl (cbt, TRUE);
+ if (ffeglobal_hook (g) != NULL)
+ assert (cbt == ffeglobal_hook (g));
- case FFEINFO_whereCONSTANT: /* Statement function. */
- assert (!ffecom_transform_only_dummies_);
- t = ffecom_gen_sfuncdef_ (s, bt, kt);
- break;
+ assert (!init || !DECL_EXTERNAL (cbt));
- case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
+ /* Make sure that any type can live in COMMON and be referenced
+ without getting a bus error. We could pick the most restrictive
+ alignment of all entities actually placed in the COMMON, but
+ this seems easy enough. */
- default:
- assert ("FUNCTION where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
- case FFEINFO_kindSUBROUTINE:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
+ if (is_init && (ffestorag_init (st) == NULL))
+ init = ffecom_init_zero_ (cbt);
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
+ finish_decl (cbt, init, TRUE);
- 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;
- }
+ if (is_init)
+ ffestorag_set_init (st, ffebld_new_any ());
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ if (init)
+ {
+ tree size_tree;
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
+ assert (DECL_SIZE (cbt) != NULL_TREE);
+ assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
+ size_tree = size_binop (CEIL_DIV_EXPR,
+ DECL_SIZE (cbt),
+ size_int (BITS_PER_UNIT));
+ assert (TREE_INT_CST_HIGH (size_tree) == 0);
+ assert (TREE_INT_CST_LOW (size_tree)
+ == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
+ }
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ ffeglobal_set_hook (g, cbt);
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
+ ffestorag_set_hook (st, cbt);
- resume_temporary_allocation ();
- pop_obstacks ();
+ resume_temporary_allocation ();
+ pop_obstacks ();
+}
- break;
+#endif
+/* Make master area for local EQUIVALENCE. */
- case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_transform_equiv_ (ffestorag eqst)
+{
+ tree eqt;
+ tree eqtype;
+ tree init;
+ tree high;
+ bool is_init = ffestorag_is_init (eqst);
+ int yes;
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
- addr = TRUE;
- break;
+ assert (eqst != NULL);
- case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
+ eqt = ffestorag_hook (eqst);
- default:
- assert ("SUBROUTINE where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ if (eqt != NULL_TREE)
+ return;
- case FFEINFO_kindPROGRAM:
- switch (ffeinfo_where (ffesymbol_info (s)))
+ /* Process inits. */
+
+ if (is_init)
+ {
+ if (ffestorag_init (eqst) != NULL)
{
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
+ ffebld sexp;
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("PROGRAM where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ /* Set the padding for the expression, so ffecom_expr
+ knows to insert that many zeros. */
+ switch (ffebld_op (sexp = ffestorag_init (eqst)))
+ {
+ case FFEBLD_opCONTER:
+ ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
- case FFEINFO_kindBLOCKDATA:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
+ case FFEBLD_opARRTER:
+ ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
+ case FFEBLD_opACCTER:
+ ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ default:
+ assert ("bad op for eqv init (pad)" == NULL);
+ break;
+ }
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_blockdata_type);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
+ init = ffecom_expr (sexp);
+ if (init == error_mark_node)
+ init = NULL_TREE; /* Hopefully the back end complained! */
+ }
+ else
+ init = error_mark_node;
+ }
+ else if (ffe_is_init_local_zero ())
+ init = error_mark_node;
+ else
+ init = NULL_TREE;
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ ffecom_member_namelisted_ = FALSE;
+ ffestorag_drive (ffestorag_list_equivs (eqst),
+ &ffecom_member_phase1_,
+ eqst);
- resume_temporary_allocation ();
- pop_obstacks ();
+ yes = suspend_momentary ();
- break;
+ high = build_int_2 ((ffestorag_size (eqst)
+ + ffestorag_modulo (eqst)) - 1, 0);
+ TREE_TYPE (high) = ffecom_integer_type_node;
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("BLOCKDATA where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ 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)),
+ -1),
+ eqtype);
+ DECL_EXTERNAL (eqt) = 0;
+ if (is_init
+ || ffecom_member_namelisted_
+#ifdef FFECOM_sizeMAXSTACKITEM
+ || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
+#endif
+ || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
+ && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
+ && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
+ TREE_STATIC (eqt) = 1;
+ else
+ TREE_STATIC (eqt) = 0;
+ TREE_PUBLIC (eqt) = 0;
+ DECL_CONTEXT (eqt) = current_function_decl;
+ if (init)
+ DECL_INITIAL (eqt) = error_mark_node;
+ else
+ DECL_INITIAL (eqt) = NULL_TREE;
- case FFEINFO_kindCOMMON:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- ffecom_transform_common_ (s);
- break;
+ eqt = start_decl (eqt, FALSE);
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("COMMON where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ /* Make sure that any type can live in EQUIVALENCE and be referenced
+ without getting a bus error. We could pick the most restrictive
+ alignment of all entities actually placed in the EQUIVALENCE, but
+ this seems easy enough. */
- case FFEINFO_kindCONSTRUCT:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- break;
+ DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("CONSTRUCT where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ if ((!is_init && ffe_is_init_local_zero ())
+ || (is_init && (ffestorag_init (eqst) == NULL)))
+ init = ffecom_init_zero_ (eqt);
- case FFEINFO_kindNAMELIST:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- t = ffecom_transform_namelist_ (s);
- break;
+ finish_decl (eqt, init, FALSE);
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("NAMELIST where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
+ if (is_init)
+ ffestorag_set_init (eqst, ffebld_new_any ());
- default:
- assert ("kind unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- t = error_mark_node;
- break;
- }
+ {
+ tree size_tree;
- ffesymbol_hook (s).decl_tree = t;
- ffesymbol_hook (s).length_tree = tlen;
- ffesymbol_hook (s).addr = addr;
+ size_tree = size_binop (CEIL_DIV_EXPR,
+ DECL_SIZE (eqt),
+ size_int (BITS_PER_UNIT));
+ assert (TREE_INT_CST_HIGH (size_tree) == 0);
+ assert (TREE_INT_CST_LOW (size_tree)
+ == ffestorag_size (eqst) + ffestorag_modulo (eqst));
+ }
- lineno = old_lineno;
- input_filename = old_input_filename;
+ ffestorag_set_hook (eqst, eqt);
- return s;
+#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
+ ffestorag_drive (ffestorag_list_equivs (eqst),
+ &ffecom_member_phase2_,
+ eqst);
+#endif
+
+ resume_momentary (yes);
}
#endif
-/* Transform into ASSIGNable symbol.
-
- Symbol has already been transformed, but for whatever reason, the
- resulting decl_tree has been deemed not usable for an ASSIGN target.
- (E.g. it isn't wide enough to hold a pointer.) So, here we invent
- another local symbol of type void * and stuff that in the assign_tree
- argument. The F77/F90 standards allow this implementation. */
+/* Implement NAMELIST in back end. See f2c/format.c for more info. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_sym_transform_assign_ (ffesymbol s)
+static tree
+ffecom_transform_namelist_ (ffesymbol s)
{
- tree t; /* Transformed thingy. */
+ tree nmlt;
+ tree nmltype = ffecom_type_namelist_ ();
+ tree nmlinits;
+ tree nameinit;
+ tree varsinit;
+ tree nvarsinit;
+ tree field;
+ tree high;
int yes;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ int i;
+ static int mynumber = 0;
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
- }
- else
- {
- ffesymbol sf = ffesymbol_sfdummyparent (s);
+ yes = suspend_momentary ();
- input_filename = ffesymbol_where_filename (sf);
- lineno = ffesymbol_where_filelinenum (sf);
- }
+ nmlt = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_namelist_%d",
+ NULL, mynumber++),
+ nmltype);
+ TREE_STATIC (nmlt) = 1;
+ DECL_INITIAL (nmlt) = error_mark_node;
- assert (!ffecom_transform_only_dummies_);
+ nmlt = start_decl (nmlt, FALSE);
- yes = suspend_momentary ();
+ /* Process inits. */
- t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
- ffesymbol_text (s),
- 0),
- TREE_TYPE (null_pointer_node));
+ i = strlen (ffesymbol_text (s));
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereLOCAL:
- /* Unlike for regular vars, SAVE status is easy to determine for
- ASSIGNed vars, since there's no initialization, there's no
- effective storage association (so "SAVE J" does not apply to
- K even given "EQUIVALENCE (J,K)"), there's no size issue
- to worry about, etc. */
- if ((ffesymbol_is_save (s) || ffe_is_saveall ())
- && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
- TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
- else
- TREE_STATIC (t) = 0; /* No need to make static. */
+ high = build_int_2 (i, 0);
+ TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
+
+ nameinit = ffecom_build_f2c_string_ (i + 1,
+ ffesymbol_text (s));
+ TREE_TYPE (nameinit)
+ = build_type_variant
+ (build_array_type
+ (char_type_node,
+ build_range_type (ffecom_f2c_ftnlen_type_node,
+ ffecom_f2c_ftnlen_one_node,
+ high)),
+ 1, 0);
+ TREE_CONSTANT (nameinit) = 1;
+ TREE_STATIC (nameinit) = 1;
+ nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
+ nameinit);
+
+ varsinit = ffecom_vardesc_array_ (s);
+ varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
+ varsinit);
+ TREE_CONSTANT (varsinit) = 1;
+ TREE_STATIC (varsinit) = 1;
+
+ {
+ ffebld b;
+
+ for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
+ ++i;
+ }
+ nvarsinit = build_int_2 (i, 0);
+ TREE_TYPE (nvarsinit) = integer_type_node;
+ TREE_CONSTANT (nvarsinit) = 1;
+ TREE_STATIC (nvarsinit) = 1;
+
+ nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
+ TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
+ varsinit);
+ TREE_CHAIN (TREE_CHAIN (nmlinits))
+ = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
+
+ nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
+ TREE_CONSTANT (nmlinits) = 1;
+ TREE_STATIC (nmlinits) = 1;
+
+ finish_decl (nmlt, nmlinits, FALSE);
+
+ nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
+
+ resume_momentary (yes);
+
+ return nmlt;
+}
+
+#endif
+
+/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
+ analyzed on the assumption it is calculating a pointer to be
+ indirected through. It must return the proper decl and offset,
+ taking into account different units of measurements for offsets. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
+ tree t)
+{
+ switch (TREE_CODE (t))
+ {
+ case NOP_EXPR:
+ case CONVERT_EXPR:
+ case NON_LVALUE_EXPR:
+ ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
break;
- case FFEINFO_whereCOMMON:
- TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
+ case PLUS_EXPR:
+ ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
+ if ((*decl == NULL_TREE)
+ || (*decl == error_mark_node))
+ break;
+
+ if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
+ {
+ /* An offset into COMMON. */
+ *offset = size_binop (PLUS_EXPR,
+ *offset,
+ TREE_OPERAND (t, 1));
+ /* Convert offset (presumably in bytes) into canonical units
+ (presumably bits). */
+ *offset = size_binop (MULT_EXPR,
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
+ *offset);
+ break;
+ }
+ /* Not a COMMON reference, so an unrecognized pattern. */
+ *decl = error_mark_node;
break;
- case FFEINFO_whereDUMMY:
- /* Note that twinning a DUMMY means the caller won't see
- the ASSIGNed value. But both F77 and F90 allow implementations
- to do this, i.e. disallow Fortran code that would try and
- take advantage of actually putting a label into a variable
- via a dummy argument (or any other storage association, for
- that matter). */
- TREE_STATIC (t) = 0;
+ case PARM_DECL:
+ *decl = t;
+ *offset = bitsize_int (0L, 0L);
break;
+ case ADDR_EXPR:
+ if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
+ {
+ /* A reference to COMMON. */
+ *decl = TREE_OPERAND (t, 0);
+ *offset = bitsize_int (0L, 0L);
+ break;
+ }
+ /* Fall through. */
default:
- TREE_STATIC (t) = 0;
+ /* Not a COMMON reference, so an unrecognized pattern. */
+ *decl = error_mark_node;
break;
}
+}
+#endif
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- resume_momentary (yes);
-
- ffesymbol_hook (s).assign_tree = t;
+/* Given a tree that is possibly intended for use as an lvalue, return
+ information representing a canonical view of that tree as a decl, an
+ offset into that decl, and a size for the lvalue.
- lineno = old_lineno;
- input_filename = old_input_filename;
+ If there's no applicable decl, NULL_TREE is returned for the decl,
+ and the other fields are left undefined.
- return s;
-}
+ If the tree doesn't fit the recognizable forms, an ERROR_MARK node
+ is returned for the decl, and the other fields are left undefined.
-#endif
-/* Implement COMMON area in back end.
+ Otherwise, the decl returned currently is either a VAR_DECL or a
+ PARM_DECL.
- Because COMMON-based variables can be referenced in the dimension
- expressions of dummy (adjustable) arrays, and because dummies
- (in the gcc back end) need to be put in the outer binding level
- of a function (which has two binding levels, the outer holding
- the dummies and the inner holding the other vars), special care
- must be taken to handle COMMON areas.
+ The offset returned is always valid, but of course not necessarily
+ a constant, and not necessarily converted into the appropriate
+ type, leaving that up to the caller (so as to avoid that overhead
+ if the decls being looked at are different anyway).
- The current strategy is basically to always tell the back end about
- the COMMON area as a top-level external reference to just a block
- of storage of the master type of that area (e.g. integer, real,
- character, whatever -- not a structure). As a distinct action,
- if initial values are provided, tell the back end about the area
- as a top-level non-external (initialized) area and remember not to
- allow further initialization or expansion of the area. Meanwhile,
- if no initialization happens at all, tell the back end about
- the largest size we've seen declared so the space does get reserved.
- (This function doesn't handle all that stuff, but it does some
- of the important things.)
+ If the size cannot be determined (e.g. an adjustable array),
+ an ERROR_MARK node is returned for the size. Otherwise, the
+ size returned is valid, not necessarily a constant, and not
+ necessarily converted into the appropriate type as with the
+ offset.
- Meanwhile, for COMMON variables themselves, just keep creating
- references like *((float *) (&common_area + offset)) each time
- we reference the variable. In other words, don't make a VAR_DECL
- or any kind of component reference (like we used to do before 0.4),
- though we might do that as well just for debugging purposes (and
- stuff the rtl with the appropriate offset expression). */
+ Note that the offset and size expressions are expressed in the
+ base storage units (usually bits) rather than in the units of
+ the type of the decl, because two decls with different types
+ might overlap but with apparently non-overlapping array offsets,
+ whereas converting the array offsets to consistant offsets will
+ reveal the overlap. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffecom_transform_common_ (ffesymbol s)
+ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
+ tree *size, tree t)
{
- 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);
+ /* The default path is to report a nonexistant decl. */
+ *decl = NULL_TREE;
- if ((g == NULL)
- || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
+ if (t == NULL_TREE)
return;
- /* First update the size of the area in global terms. */
+ switch (TREE_CODE (t))
+ {
+ case ERROR_MARK:
+ case IDENTIFIER_NODE:
+ case INTEGER_CST:
+ case REAL_CST:
+ case COMPLEX_CST:
+ case STRING_CST:
+ case CONST_DECL:
+ case PLUS_EXPR:
+ case MINUS_EXPR:
+ case MULT_EXPR:
+ case TRUNC_DIV_EXPR:
+ case CEIL_DIV_EXPR:
+ case FLOOR_DIV_EXPR:
+ case ROUND_DIV_EXPR:
+ case TRUNC_MOD_EXPR:
+ case CEIL_MOD_EXPR:
+ case FLOOR_MOD_EXPR:
+ case ROUND_MOD_EXPR:
+ case RDIV_EXPR:
+ case EXACT_DIV_EXPR:
+ case FIX_TRUNC_EXPR:
+ case FIX_CEIL_EXPR:
+ case FIX_FLOOR_EXPR:
+ case FIX_ROUND_EXPR:
+ case FLOAT_EXPR:
+ case EXPON_EXPR:
+ case NEGATE_EXPR:
+ case MIN_EXPR:
+ case MAX_EXPR:
+ case ABS_EXPR:
+ case FFS_EXPR:
+ case LSHIFT_EXPR:
+ case RSHIFT_EXPR:
+ case LROTATE_EXPR:
+ case RROTATE_EXPR:
+ case BIT_IOR_EXPR:
+ case BIT_XOR_EXPR:
+ case BIT_AND_EXPR:
+ case BIT_ANDTC_EXPR:
+ case BIT_NOT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ case TRUTH_NOT_EXPR:
+ case LT_EXPR:
+ case LE_EXPR:
+ case GT_EXPR:
+ case GE_EXPR:
+ case EQ_EXPR:
+ case NE_EXPR:
+ case COMPLEX_EXPR:
+ case CONJ_EXPR:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ case LABEL_EXPR:
+ case COMPONENT_REF:
+ case COMPOUND_EXPR:
+ case ADDR_EXPR:
+ return;
- ffeglobal_size_common (s, ffestorag_size (st));
+ case VAR_DECL:
+ case PARM_DECL:
+ *decl = t;
+ *offset = bitsize_int (0L, 0L);
+ *size = TYPE_SIZE (TREE_TYPE (t));
+ return;
- if (!ffeglobal_common_init (g))
- is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
+ case ARRAY_REF:
+ {
+ tree array = TREE_OPERAND (t, 0);
+ tree element = TREE_OPERAND (t, 1);
+ tree init_offset;
+
+ if ((array == NULL_TREE)
+ || (element == NULL_TREE))
+ {
+ *decl = error_mark_node;
+ return;
+ }
+
+ ffecom_tree_canonize_ref_ (decl, &init_offset, size,
+ array);
+ if ((*decl == NULL_TREE)
+ || (*decl == error_mark_node))
+ return;
+
+ *offset = size_binop (MULT_EXPR,
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
+ size_binop (MINUS_EXPR,
+ element,
+ TYPE_MIN_VALUE
+ (TYPE_DOMAIN
+ (TREE_TYPE (array)))));
+
+ *offset = size_binop (PLUS_EXPR,
+ init_offset,
+ *offset);
+
+ *size = TYPE_SIZE (TREE_TYPE (t));
+ return;
+ }
+
+ case INDIRECT_REF:
+
+ /* Most of this code is to handle references to COMMON. And so
+ far that is useful only for calling library functions, since
+ external (user) functions might reference common areas. But
+ even calling an external function, it's worthwhile to decode
+ COMMON references because if not storing into COMMON, we don't
+ want COMMON-based arguments to gratuitously force use of a
+ temporary. */
+
+ *size = TYPE_SIZE (TREE_TYPE (t));
- cbt = ffeglobal_hook (g);
+ ffecom_tree_canonize_ptr_ (decl, offset,
+ TREE_OPERAND (t, 0));
- /* If we already have declared this common block for a previous program
- unit, and either we already initialized it or we don't have new
- initialization for it, just return what we have without changing it. */
+ return;
- if ((cbt != NULL_TREE)
- && (!is_init
- || !DECL_EXTERNAL (cbt)))
- return;
+ case CONVERT_EXPR:
+ case NOP_EXPR:
+ case MODIFY_EXPR:
+ case NON_LVALUE_EXPR:
+ case RESULT_DECL:
+ case FIELD_DECL:
+ case COND_EXPR: /* More cases than we can handle. */
+ case SAVE_EXPR:
+ case REFERENCE_EXPR:
+ case PREDECREMENT_EXPR:
+ case PREINCREMENT_EXPR:
+ case POSTDECREMENT_EXPR:
+ case POSTINCREMENT_EXPR:
+ case CALL_EXPR:
+ default:
+ *decl = error_mark_node;
+ return;
+ }
+}
+#endif
- /* Process inits. */
+/* Do divide operation appropriate to type of operands. */
- if (is_init)
- {
- if (ffestorag_init (st) != NULL)
- {
- ffebld sexp;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_tree_divide_ (tree tree_type, tree left, tree right,
+ tree dest_tree, ffebld dest, bool *dest_used,
+ tree hook)
+{
+ if ((left == error_mark_node)
+ || (right == error_mark_node))
+ return error_mark_node;
- /* Set the padding for the expression, so ffecom_expr
- knows to insert that many zeros. */
- switch (ffebld_op (sexp = ffestorag_init (st)))
- {
- case FFEBLD_opCONTER:
- ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
- break;
+ switch (TREE_CODE (tree_type))
+ {
+ case INTEGER_TYPE:
+ return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
+ left,
+ right);
- case FFEBLD_opARRTER:
- ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
- break;
+ case COMPLEX_TYPE:
+ {
+ ffecomGfrt ix;
- case FFEBLD_opACCTER:
- ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
- break;
+ if (TREE_TYPE (tree_type)
+ == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
+ ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
+ else
+ ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
- default:
- assert ("bad op for cmn init (pad)" == NULL);
- break;
- }
+ 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;
- init = ffecom_expr (sexp);
- if (init == error_mark_node)
- { /* Hopefully the back end complained! */
- init = NULL_TREE;
- if (cbt != NULL_TREE)
- return;
- }
- }
- else
- init = error_mark_node;
- }
- else
- init = NULL_TREE;
+ 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;
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ case RECORD_TYPE:
+ {
+ ffecomGfrt ix;
- /* cbtype must be permanently allocated! */
+ if (TREE_TYPE (TYPE_FIELDS (tree_type))
+ == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
+ ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
+ else
+ ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
- /* Allocate the MAX of the areas so far, seen filewide. */
- high = build_int_2 ((ffeglobal_common_size (g)
- + ffeglobal_common_pad (g)) - 1, 0);
- TREE_TYPE (high) = ffecom_integer_type_node;
+ 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;
- 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);
+ 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;
- 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;
+ default:
+ return ffecom_2 (RDIV_EXPR, tree_type,
+ left,
+ right);
}
- 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));
+#endif
+/* Build type info for non-dummy variable. */
- assert (!init || !DECL_EXTERNAL (cbt));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
+ ffeinfoKindtype kt)
+{
+ tree type;
+ ffebld dl;
+ ffebld dim;
+ tree lowt;
+ tree hight;
- /* Make sure that any type can live in COMMON and be referenced
- without getting a bus error. We could pick the most restrictive
- alignment of all entities actually placed in the COMMON, but
- this seems easy enough. */
+ 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;
- DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
+ 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);
+ }
- if (is_init && (ffestorag_init (st) == NULL))
- init = ffecom_init_zero_ (cbt);
+ for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
+ {
+ if (type == error_mark_node)
+ break;
- finish_decl (cbt, init, TRUE);
+ dim = ffebld_head (dl);
+ assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- if (is_init)
- ffestorag_set_init (st, ffebld_new_any ());
+ if (ffebld_left (dim) == NULL)
+ lowt = integer_one_node;
+ else
+ lowt = ffecom_expr (ffebld_left (dim));
- if (init)
- {
- tree size_tree;
+ if (TREE_CODE (lowt) != INTEGER_CST)
+ lowt = variable_size (lowt);
- assert (DECL_SIZE (cbt) != NULL_TREE);
- assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (cbt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree)
- == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
- }
+ assert (ffebld_right (dim) != NULL);
+ hight = ffecom_expr (ffebld_right (dim));
- ffeglobal_set_hook (g, cbt);
+ if (TREE_CODE (hight) != INTEGER_CST)
+ hight = variable_size (hight);
- ffestorag_set_hook (st, cbt);
+ type = build_array_type (type,
+ build_range_type (ffecom_integer_type_node,
+ lowt, hight));
+ type = ffecom_check_size_overflow_ (s, type, FALSE);
+ }
- resume_temporary_allocation ();
- pop_obstacks ();
+ return type;
}
#endif
-/* Make master area for local EQUIVALENCE. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_transform_equiv_ (ffestorag eqst)
-{
- tree eqt;
- tree eqtype;
- tree init;
- tree high;
- bool is_init = ffestorag_is_init (eqst);
- int yes;
-
- assert (eqst != NULL);
+/* Build Namelist type. */
- eqt = ffestorag_hook (eqst);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_type_namelist_ ()
+{
+ static tree type = NULL_TREE;
- if (eqt != NULL_TREE)
- return;
+ if (type == NULL_TREE)
+ {
+ static tree namefield, varsfield, nvarsfield;
+ tree vardesctype;
- /* Process inits. */
+ vardesctype = ffecom_type_vardesc_ ();
- if (is_init)
- {
- if (ffestorag_init (eqst) != NULL)
- {
- ffebld sexp;
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- /* Set the padding for the expression, so ffecom_expr
- knows to insert that many zeros. */
- switch (ffebld_op (sexp = ffestorag_init (eqst)))
- {
- case FFEBLD_opCONTER:
- ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
+ type = make_node (RECORD_TYPE);
- case FFEBLD_opARRTER:
- ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
+ vardesctype = build_pointer_type (build_pointer_type (vardesctype));
- case FFEBLD_opACCTER:
- ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
- break;
+ 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);
- default:
- assert ("bad op for eqv init (pad)" == NULL);
- break;
- }
+ TYPE_FIELDS (type) = namefield;
+ layout_type (type);
- init = ffecom_expr (sexp);
- if (init == error_mark_node)
- init = NULL_TREE; /* Hopefully the back end complained! */
- }
- else
- init = error_mark_node;
+ resume_temporary_allocation ();
+ pop_obstacks ();
}
- 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);
+ return type;
+}
- yes = suspend_momentary ();
+#endif
- high = build_int_2 ((ffestorag_size (eqst)
- + ffestorag_modulo (eqst)) - 1, 0);
- TREE_TYPE (high) = ffecom_integer_type_node;
+/* Make a copy of a type, assuming caller has switched to the permanent
+ obstacks and that the type is for an aggregate (array) initializer. */
- eqtype = build_array_type (char_type_node,
- build_range_type (ffecom_integer_type_node,
- ffecom_integer_zero_node,
- high));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
+static tree
+ffecom_type_permanent_copy_ (tree t)
+{
+ tree domain;
+ tree max;
- eqt = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_equiv_%s",
- ffesymbol_text
- (ffestorag_symbol
- (eqst)),
- 0),
- eqtype);
- DECL_EXTERNAL (eqt) = 0;
- if (is_init
- || ffecom_member_namelisted_
-#ifdef FFECOM_sizeMAXSTACKITEM
- || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
-#endif
- || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
- && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
- TREE_STATIC (eqt) = 1;
- else
- TREE_STATIC (eqt) = 0;
- TREE_PUBLIC (eqt) = 0;
- DECL_CONTEXT (eqt) = current_function_decl;
- if (init)
- DECL_INITIAL (eqt) = error_mark_node;
- else
- DECL_INITIAL (eqt) = NULL_TREE;
+ assert (TREE_TYPE (t) != NULL_TREE);
- eqt = start_decl (eqt, FALSE);
+ domain = TYPE_DOMAIN (t);
- /* Make sure that any type can live in EQUIVALENCE and be referenced
- without getting a bus error. We could pick the most restrictive
- alignment of all entities actually placed in the EQUIVALENCE, but
- this seems easy enough. */
+ assert (TREE_CODE (t) == ARRAY_TYPE);
+ assert (TREE_PERMANENT (TREE_TYPE (t)));
+ assert (TREE_PERMANENT (TREE_TYPE (domain)));
+ assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
- DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
+ max = TYPE_MAX_VALUE (domain);
+ if (!TREE_PERMANENT (max))
+ {
+ assert (TREE_CODE (max) == INTEGER_CST);
- if ((!is_init && ffe_is_init_local_zero ())
- || (is_init && (ffestorag_init (eqst) == NULL)))
- init = ffecom_init_zero_ (eqt);
+ max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
+ TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
+ }
- finish_decl (eqt, init, FALSE);
+ return build_array_type (TREE_TYPE (t),
+ build_range_type (TREE_TYPE (domain),
+ TYPE_MIN_VALUE (domain),
+ max));
+}
+#endif
- if (is_init)
- ffestorag_set_init (eqst, ffebld_new_any ());
+/* Build Vardesc type. */
- {
- tree size_tree;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_type_vardesc_ ()
+{
+ static tree type = NULL_TREE;
+ static tree namefield, addrfield, dimsfield, typefield;
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (eqt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree)
- == ffestorag_size (eqst) + ffestorag_modulo (eqst));
- }
+ if (type == NULL_TREE)
+ {
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- ffestorag_set_hook (eqst, eqt);
+ type = make_node (RECORD_TYPE);
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
- ffestorag_drive (ffestorag_list_equivs (eqst),
- &ffecom_member_phase2_,
- eqst);
-#endif
+ 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);
- resume_momentary (yes);
+ TYPE_FIELDS (type) = namefield;
+ layout_type (type);
+
+ resume_temporary_allocation ();
+ pop_obstacks ();
+ }
+
+ return type;
}
#endif
-/* Implement NAMELIST in back end. See f2c/format.c for more info. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_transform_namelist_ (ffesymbol s)
+ffecom_vardesc_ (ffebld expr)
{
- tree nmlt;
- tree nmltype = ffecom_type_namelist_ ();
- tree nmlinits;
- tree nameinit;
- tree varsinit;
- tree nvarsinit;
- tree field;
- tree high;
- int yes;
- int i;
- static int mynumber = 0;
+ ffesymbol s;
- yes = suspend_momentary ();
+ assert (ffebld_op (expr) == FFEBLD_opSYMTER);
+ s = ffebld_symter (expr);
- nmlt = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_namelist_%d",
- NULL, mynumber++),
- nmltype);
- TREE_STATIC (nmlt) = 1;
- DECL_INITIAL (nmlt) = error_mark_node;
+ if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
+ {
+ int i;
+ tree vardesctype = ffecom_type_vardesc_ ();
+ tree var;
+ tree nameinit;
+ tree dimsinit;
+ tree addrinit;
+ tree typeinit;
+ tree field;
+ tree varinits;
+ int yes;
+ static int mynumber = 0;
- nmlt = start_decl (nmlt, FALSE);
+ yes = suspend_momentary ();
- /* Process inits. */
+ var = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_vardesc_%d",
+ NULL, mynumber++),
+ vardesctype);
+ TREE_STATIC (var) = 1;
+ DECL_INITIAL (var) = error_mark_node;
- i = strlen (ffesymbol_text (s));
+ var = start_decl (var, FALSE);
- high = build_int_2 (i, 0);
- TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
+ /* Process inits. */
- 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);
+ 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);
- 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;
+ addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
- {
- ffebld b;
+ dimsinit = ffecom_vardesc_dims_ (s);
- 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;
+ if (typeinit == NULL_TREE)
+ {
+ ffeinfoBasictype bt = ffesymbol_basictype (s);
+ ffeinfoKindtype kt = ffesymbol_kindtype (s);
+ int tc = ffecom_f2c_typecode (bt, kt);
- 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);
+ assert (tc != -1);
+ typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
+ }
+ else
+ typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
- nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
- TREE_CONSTANT (nmlinits) = 1;
- TREE_STATIC (nmlinits) = 1;
+ 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);
- finish_decl (nmlt, nmlinits, FALSE);
+ varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
+ TREE_CONSTANT (varinits) = 1;
+ TREE_STATIC (varinits) = 1;
- nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
+ finish_decl (var, varinits, FALSE);
- resume_momentary (yes);
+ var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
- return nmlt;
-}
+ resume_momentary (yes);
-#endif
+ ffesymbol_hook (s).vardesc_tree = var;
+ }
-/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
- analyzed on the assumption it is calculating a pointer to be
- indirected through. It must return the proper decl and offset,
- taking into account different units of measurements for offsets. */
+ return ffesymbol_hook (s).vardesc_tree;
+}
+#endif
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
- tree t)
+static tree
+ffecom_vardesc_array_ (ffesymbol s)
{
- 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;
+ ffebld b;
+ tree list;
+ tree item = NULL_TREE;
+ tree var;
+ int i;
+ int yes;
+ static int mynumber = 0;
- if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
- {
- /* An offset into COMMON. */
- *offset = size_binop (PLUS_EXPR,
- *offset,
- TREE_OPERAND (t, 1));
- /* Convert offset (presumably in bytes) into canonical units
- (presumably bits). */
- *offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
- *offset);
- break;
- }
- /* Not a COMMON reference, so an unrecognized pattern. */
- *decl = error_mark_node;
- break;
+ for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
+ b != NULL;
+ b = ffebld_trail (b), ++i)
+ {
+ tree t;
- case PARM_DECL:
- *decl = t;
- *offset = bitsize_int (0L, 0L);
- break;
+ t = ffecom_vardesc_ (ffebld_head (b));
- case ADDR_EXPR:
- if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
+ if (list == NULL_TREE)
+ list = item = build_tree_list (NULL_TREE, t);
+ else
{
- /* A reference to COMMON. */
- *decl = TREE_OPERAND (t, 0);
- *offset = bitsize_int (0L, 0L);
- break;
+ TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
+ item = TREE_CHAIN (item);
}
- /* Fall through. */
- default:
- /* Not a COMMON reference, so an unrecognized pattern. */
- *decl = error_mark_node;
- break;
}
-}
-#endif
-
-/* Given a tree that is possibly intended for use as an lvalue, return
- information representing a canonical view of that tree as a decl, an
- offset into that decl, and a size for the lvalue.
-
- If there's no applicable decl, NULL_TREE is returned for the decl,
- and the other fields are left undefined.
-
- If the tree doesn't fit the recognizable forms, an ERROR_MARK node
- is returned for the decl, and the other fields are left undefined.
-
- Otherwise, the decl returned currently is either a VAR_DECL or a
- PARM_DECL.
-
- The offset returned is always valid, but of course not necessarily
- a constant, and not necessarily converted into the appropriate
- type, leaving that up to the caller (so as to avoid that overhead
- if the decls being looked at are different anyway).
- If the size cannot be determined (e.g. an adjustable array),
- an ERROR_MARK node is returned for the size. Otherwise, the
- size returned is valid, not necessarily a constant, and not
- necessarily converted into the appropriate type as with the
- offset.
+ yes = suspend_momentary ();
- Note that the offset and size expressions are expressed in the
- base storage units (usually bits) rather than in the units of
- the type of the decl, because two decls with different types
- might overlap but with apparently non-overlapping array offsets,
- whereas converting the array offsets to consistant offsets will
- reveal the overlap. */
+ 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;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
- tree *size, tree t)
-{
- /* The default path is to report a nonexistant decl. */
- *decl = NULL_TREE;
+ var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
+ mynumber++);
+ var = build_decl (VAR_DECL, var, item);
+ TREE_STATIC (var) = 1;
+ DECL_INITIAL (var) = error_mark_node;
+ var = start_decl (var, FALSE);
+ finish_decl (var, list, FALSE);
- if (t == NULL_TREE)
- return;
+ resume_momentary (yes);
- switch (TREE_CODE (t))
- {
- case ERROR_MARK:
- case IDENTIFIER_NODE:
- case INTEGER_CST:
- case REAL_CST:
- case COMPLEX_CST:
- case STRING_CST:
- case CONST_DECL:
- case PLUS_EXPR:
- case MINUS_EXPR:
- case MULT_EXPR:
- case TRUNC_DIV_EXPR:
- case CEIL_DIV_EXPR:
- case FLOOR_DIV_EXPR:
- case ROUND_DIV_EXPR:
- case TRUNC_MOD_EXPR:
- case CEIL_MOD_EXPR:
- case FLOOR_MOD_EXPR:
- case ROUND_MOD_EXPR:
- case RDIV_EXPR:
- case EXACT_DIV_EXPR:
- case FIX_TRUNC_EXPR:
- case FIX_CEIL_EXPR:
- case FIX_FLOOR_EXPR:
- case FIX_ROUND_EXPR:
- case FLOAT_EXPR:
- case EXPON_EXPR:
- case NEGATE_EXPR:
- case MIN_EXPR:
- case MAX_EXPR:
- case ABS_EXPR:
- case FFS_EXPR:
- case LSHIFT_EXPR:
- case RSHIFT_EXPR:
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- case BIT_IOR_EXPR:
- case BIT_XOR_EXPR:
- case BIT_AND_EXPR:
- case BIT_ANDTC_EXPR:
- case BIT_NOT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- case TRUTH_NOT_EXPR:
- case LT_EXPR:
- case LE_EXPR:
- case GT_EXPR:
- case GE_EXPR:
- case EQ_EXPR:
- case NE_EXPR:
- case COMPLEX_EXPR:
- case CONJ_EXPR:
- case REALPART_EXPR:
- case IMAGPART_EXPR:
- case LABEL_EXPR:
- case COMPONENT_REF:
- case COMPOUND_EXPR:
- case ADDR_EXPR:
- return;
+ return var;
+}
- case VAR_DECL:
- case PARM_DECL:
- *decl = t;
- *offset = bitsize_int (0L, 0L);
- *size = TYPE_SIZE (TREE_TYPE (t));
- return;
+#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_vardesc_dims_ (ffesymbol s)
+{
+ if (ffesymbol_dims (s) == NULL)
+ return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
+ integer_zero_node);
- case ARRAY_REF:
+ {
+ ffebld b;
+ ffebld e;
+ tree list;
+ tree backlist;
+ tree item = NULL_TREE;
+ tree var;
+ int yes;
+ tree numdim;
+ tree numelem;
+ tree baseoff = NULL_TREE;
+ static int mynumber = 0;
+
+ numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
+ TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
+
+ numelem = ffecom_expr (ffesymbol_arraysize (s));
+ TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
+
+ list = NULL_TREE;
+ backlist = NULL_TREE;
+ for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
+ b != NULL;
+ b = ffebld_trail (b), e = ffebld_trail (e))
{
- tree array = TREE_OPERAND (t, 0);
- tree element = TREE_OPERAND (t, 1);
- tree init_offset;
+ tree t;
+ tree low;
+ tree back;
- if ((array == NULL_TREE)
- || (element == NULL_TREE))
+ if (ffebld_trail (b) == NULL)
+ t = NULL_TREE;
+ else
{
- *decl = error_mark_node;
- return;
- }
+ t = convert (ffecom_f2c_ftnlen_type_node,
+ ffecom_expr (ffebld_head (e)));
- ffecom_tree_canonize_ref_ (decl, &init_offset, size,
- array);
- if ((*decl == NULL_TREE)
- || (*decl == error_mark_node))
- return;
+ 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);
+ }
+ }
- *offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
- size_binop (MINUS_EXPR,
- element,
- TYPE_MIN_VALUE
- (TYPE_DOMAIN
- (TREE_TYPE (array)))));
+ 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);
- *offset = size_binop (PLUS_EXPR,
- init_offset,
- *offset);
+ back = build_tree_list (low, t);
+ TREE_CHAIN (back) = backlist;
+ backlist = back;
+ }
- *size = TYPE_SIZE (TREE_TYPE (t));
- return;
+ 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));
}
- case INDIRECT_REF:
+ /* backlist now dead, along with all TREE_PURPOSEs on it. */
- /* Most of this code is to handle references to COMMON. And so
- far that is useful only for calling library functions, since
- external (user) functions might reference common areas. But
- even calling an external function, it's worthwhile to decode
- COMMON references because if not storing into COMMON, we don't
- want COMMON-based arguments to gratuitously force use of a
- temporary. */
+ baseoff = build_tree_list (NULL_TREE, baseoff);
+ TREE_CHAIN (baseoff) = list;
- *size = TYPE_SIZE (TREE_TYPE (t));
+ numelem = build_tree_list (NULL_TREE, numelem);
+ TREE_CHAIN (numelem) = baseoff;
- ffecom_tree_canonize_ptr_ (decl, offset,
- TREE_OPERAND (t, 0));
+ numdim = build_tree_list (NULL_TREE, numdim);
+ TREE_CHAIN (numdim) = numelem;
- return;
+ yes = suspend_momentary ();
- case CONVERT_EXPR:
- case NOP_EXPR:
- case MODIFY_EXPR:
- case NON_LVALUE_EXPR:
- case RESULT_DECL:
- case FIELD_DECL:
- case COND_EXPR: /* More cases than we can handle. */
- case SAVE_EXPR:
- case REFERENCE_EXPR:
- case PREDECREMENT_EXPR:
- case PREINCREMENT_EXPR:
- case POSTDECREMENT_EXPR:
- case POSTINCREMENT_EXPR:
- case CALL_EXPR:
- default:
- *decl = error_mark_node;
- return;
- }
+ item = build_array_type (ffecom_f2c_ftnlen_type_node,
+ build_range_type (integer_type_node,
+ integer_zero_node,
+ build_int_2
+ ((int) ffesymbol_rank (s)
+ + 2, 0)));
+ list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
+ TREE_CONSTANT (list) = 1;
+ TREE_STATIC (list) = 1;
+
+ var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
+ mynumber++);
+ var = build_decl (VAR_DECL, var, item);
+ TREE_STATIC (var) = 1;
+ DECL_INITIAL (var) = error_mark_node;
+ var = start_decl (var, FALSE);
+ finish_decl (var, list, FALSE);
+
+ var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
+
+ resume_momentary (yes);
+
+ return var;
+ }
}
+
#endif
+/* Essentially does a "fold (build1 (code, type, node))" while checking
+ for certain housekeeping things.
-/* Do divide operation appropriate to type of operands. */
+ NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
+ ffecom_1_fn instead. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_tree_divide_ (tree tree_type, tree left, tree right,
- tree dest_tree, ffebld dest, bool *dest_used)
+tree
+ffecom_1 (enum tree_code code, tree type, tree node)
{
- if ((left == error_mark_node)
- || (right == error_mark_node))
+ tree item;
+
+ if ((node == error_mark_node)
+ || (type == error_mark_node))
return error_mark_node;
- switch (TREE_CODE (tree_type))
+ if (code == ADDR_EXPR)
{
- case INTEGER_TYPE:
- return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
- left,
- right);
-
- case COMPLEX_TYPE:
- {
- ffecomGfrt ix;
-
- if (TREE_TYPE (tree_type)
- == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
- ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
- else
- ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
+ if (!mark_addressable (node))
+ assert ("can't mark_addressable this node!" == NULL);
+ }
- 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;
+ switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
+ {
+ tree realtype;
- 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);
- }
+ case REALPART_EXPR:
+ item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
break;
- case RECORD_TYPE:
- {
- ffecomGfrt ix;
-
- if (TREE_TYPE (TYPE_FIELDS (tree_type))
- == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
- ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
- else
- ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
+ case IMAGPART_EXPR:
+ item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
+ break;
- 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);
- }
+ 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:
- return ffecom_2 (RDIV_EXPR, tree_type,
- left,
- right);
+ item = build1 (code, type, node);
+ break;
}
-}
+ if (TREE_SIDE_EFFECTS (node))
+ TREE_SIDE_EFFECTS (item) = 1;
+ if ((code == ADDR_EXPR) && staticp (node))
+ TREE_CONSTANT (item) = 1;
+ return fold (item);
+}
#endif
-/* ffecom_type_localvar_ -- Build type info for non-dummy variable
-
- tree type;
- ffesymbol s; // the variable's symbol
- ffeinfoBasictype bt; // it's basictype
- ffeinfoKindtype kt; // it's kindtype
- type = ffecom_type_localvar_(s,bt,kt);
-
- Handles static arrays, CHARACTER type, etc. */
+/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
+ handles TREE_CODE (node) == FUNCTION_DECL. In particular,
+ does not set TREE_ADDRESSABLE (because calling an inline
+ function does not mean the function needs to be separately
+ compiled). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
- ffeinfoKindtype kt)
+tree
+ffecom_1_fn (tree node)
{
+ tree item;
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);
- }
+ if (node == error_mark_node)
+ return error_mark_node;
- return type;
+ type = build_type_variant (TREE_TYPE (node),
+ TREE_READONLY (node),
+ TREE_THIS_VOLATILE (node));
+ item = build1 (ADDR_EXPR,
+ build_pointer_type (type), node);
+ if (TREE_SIDE_EFFECTS (node))
+ TREE_SIDE_EFFECTS (item) = 1;
+ if (staticp (node))
+ TREE_CONSTANT (item) = 1;
+ return fold (item);
}
-
#endif
-/* Build Namelist type. */
+
+/* Essentially does a "fold (build (code, type, node1, node2))" while
+ checking for certain housekeeping things. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_type_namelist_ ()
+tree
+ffecom_2 (enum tree_code code, tree type, tree node1,
+ tree node2)
{
- static tree type = NULL_TREE;
+ tree item;
- if (type == NULL_TREE)
+ 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)
{
- static tree namefield, varsfield, nvarsfield;
- tree vardesctype;
+ tree a, b, c, d, realtype;
- vardesctype = ffecom_type_vardesc_ ();
+ case CONJ_EXPR:
+ assert ("no CONJ_EXPR support yet" == NULL);
+ return error_mark_node;
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ 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;
- type = make_node (RECORD_TYPE);
+ 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;
- vardesctype = build_pointer_type (build_pointer_type (vardesctype));
+ 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;
- 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);
+ 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;
- TYPE_FIELDS (type) = namefield;
- layout_type (type);
+ 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;
- resume_temporary_allocation ();
- pop_obstacks ();
+ default:
+ item = build (code, type, node1, node2);
+ break;
}
- return type;
+ if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (item);
}
#endif
+/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
-/* Make a copy of a type, assuming caller has switched to the permanent
- obstacks and that the type is for an aggregate (array) initializer. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
-static tree
-ffecom_type_permanent_copy_ (tree t)
-{
- tree domain;
- tree max;
-
- assert (TREE_TYPE (t) != NULL_TREE);
-
- domain = TYPE_DOMAIN (t);
-
- assert (TREE_CODE (t) == ARRAY_TYPE);
- assert (TREE_PERMANENT (TREE_TYPE (t)));
- assert (TREE_PERMANENT (TREE_TYPE (domain)));
- assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
-
- max = TYPE_MAX_VALUE (domain);
- if (!TREE_PERMANENT (max))
- {
- assert (TREE_CODE (max) == INTEGER_CST);
+ ffesymbol s; // the ENTRY point itself
+ if (ffecom_2pass_advise_entrypoint(s))
+ // the ENTRY point has been accepted
- max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
- TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
- }
+ Does whatever compiler needs to do when it learns about the entrypoint,
+ like determine the return type of the master function, count the
+ number of entrypoints, etc. Returns FALSE if the return type is
+ not compatible with the return type(s) of other entrypoint(s).
- return build_array_type (TREE_TYPE (t),
- build_range_type (TREE_TYPE (domain),
- TYPE_MIN_VALUE (domain),
- max));
-}
-#endif
+ NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
+ later (after _finish_progunit) be called with the same entrypoint(s)
+ as passed to this fn for which TRUE was returned.
-/* Build Vardesc type. */
+ 03-Jan-92 JCB 2.0
+ Return FALSE if the return type conflicts with previous entrypoints. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_type_vardesc_ ()
+bool
+ffecom_2pass_advise_entrypoint (ffesymbol entry)
{
- static tree type = NULL_TREE;
- static tree namefield, addrfield, dimsfield, typefield;
-
- if (type == NULL_TREE)
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- type = make_node (RECORD_TYPE);
+ ffebld list; /* opITEM. */
+ ffebld mlist; /* opITEM. */
+ ffebld plist; /* opITEM. */
+ ffebld arg; /* ffebld_head(opITEM). */
+ ffebld item; /* opITEM. */
+ ffesymbol s; /* ffebld_symter(arg). */
+ ffeinfoBasictype bt = ffesymbol_basictype (entry);
+ ffeinfoKindtype kt = ffesymbol_kindtype (entry);
+ ffetargetCharacterSize size = ffesymbol_size (entry);
+ bool ok;
- 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);
+ if (ffecom_num_entrypoints_ == 0)
+ { /* First entrypoint, make list of main
+ arglist's dummies. */
+ assert (ffecom_primary_entry_ != NULL);
- TYPE_FIELDS (type) = namefield;
- layout_type (type);
+ ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
+ ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
+ ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
- resume_temporary_allocation ();
- pop_obstacks ();
+ for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
+ list != NULL;
+ list = ffebld_trail (list))
+ {
+ arg = ffebld_head (list);
+ if (ffebld_op (arg) != FFEBLD_opSYMTER)
+ continue; /* Alternate return or some such thing. */
+ item = ffebld_new_item (arg, NULL);
+ if (plist == NULL)
+ ffecom_master_arglist_ = item;
+ else
+ ffebld_set_trail (plist, item);
+ plist = item;
+ }
}
- return type;
-}
-
-#endif
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_vardesc_ (ffebld expr)
-{
- ffesymbol s;
-
- assert (ffebld_op (expr) == FFEBLD_opSYMTER);
- s = ffebld_symter (expr);
+ /* If necessary, scan entry arglist for alternate returns. Do this scan
+ apparently redundantly (it's done below to UNIONize the arglists) so
+ that we don't complain about RETURN 1 if an offending ENTRY is the only
+ one with an alternate return. */
- if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
+ if (!ffecom_is_altreturning_)
{
- int i;
- tree vardesctype = ffecom_type_vardesc_ ();
- tree var;
- tree nameinit;
- tree dimsinit;
- tree addrinit;
- tree typeinit;
- tree field;
- tree varinits;
- int yes;
- static int mynumber = 0;
-
- yes = suspend_momentary ();
-
- var = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_vardesc_%d",
- NULL, mynumber++),
- vardesctype);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
-
- var = start_decl (var, FALSE);
+ 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;
+ }
+ }
+ }
- /* Process inits. */
+ /* Now check type compatibility. */
- 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);
+ switch (ffecom_master_bt_)
+ {
+ case FFEINFO_basictypeNONE:
+ ok = (bt != FFEINFO_basictypeCHARACTER);
+ break;
- addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
+ case FFEINFO_basictypeCHARACTER:
+ ok
+ = (bt == FFEINFO_basictypeCHARACTER)
+ && (kt == ffecom_master_kt_)
+ && (size == ffecom_master_size_);
+ break;
- dimsinit = ffecom_vardesc_dims_ (s);
+ case FFEINFO_basictypeANY:
+ return FALSE; /* Just don't bother. */
- if (typeinit == NULL_TREE)
+ default:
+ if (bt == FFEINFO_basictypeCHARACTER)
{
- 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);
+ ok = FALSE;
+ break;
}
- else
- typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
+ ok = TRUE;
+ if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
+ {
+ ffecom_master_bt_ = FFEINFO_basictypeNONE;
+ ffecom_master_kt_ = FFEINFO_kindtypeNONE;
+ }
+ break;
+ }
- 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);
+ if (!ok)
+ {
+ ffebad_start (FFEBAD_ENTRY_CONFLICTS);
+ ffest_ffebad_here_current_stmt (0);
+ ffebad_finish ();
+ return FALSE; /* Can't handle entrypoint. */
+ }
- varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
- TREE_CONSTANT (varinits) = 1;
- TREE_STATIC (varinits) = 1;
+ /* Entrypoint type compatible with previous types. */
- finish_decl (var, varinits, FALSE);
+ ++ffecom_num_entrypoints_;
- var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
+ /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
+
+ for (list = ffesymbol_dummyargs (entry);
+ list != NULL;
+ list = ffebld_trail (list))
+ {
+ arg = ffebld_head (list);
+ if (ffebld_op (arg) != FFEBLD_opSYMTER)
+ continue; /* Alternate return or some such thing. */
+ s = ffebld_symter (arg);
+ for (plist = NULL, mlist = ffecom_master_arglist_;
+ mlist != NULL;
+ plist = mlist, mlist = ffebld_trail (mlist))
+ { /* plist points to previous item for easy
+ appending of arg. */
+ if (ffebld_symter (ffebld_head (mlist)) == s)
+ break; /* Already have this arg in the master list. */
+ }
+ if (mlist != NULL)
+ continue; /* Already have this arg in the master list. */
- resume_momentary (yes);
+ /* Append this arg to the master list. */
- ffesymbol_hook (s).vardesc_tree = var;
+ item = ffebld_new_item (arg, NULL);
+ if (plist == NULL)
+ ffecom_master_arglist_ = item;
+ else
+ ffebld_set_trail (plist, item);
}
- return ffesymbol_hook (s).vardesc_tree;
+ return TRUE;
}
#endif
+/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
+
+ ffesymbol s; // the ENTRY point itself
+ ffecom_2pass_do_entrypoint(s);
+
+ Does whatever compiler needs to do to make the entrypoint actually
+ happen. Must be called for each entrypoint after
+ ffecom_finish_progunit is called. */
+
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_vardesc_array_ (ffesymbol s)
+void
+ffecom_2pass_do_entrypoint (ffesymbol entry)
{
- ffebld b;
- tree list;
- tree item = NULL_TREE;
- tree var;
- int i;
- int yes;
- static int mynumber = 0;
+ static int mfn_num = 0;
+ static int ent_num;
- for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
- b != NULL;
- b = ffebld_trail (b), ++i)
- {
- tree t;
+ if (mfn_num != ffecom_num_fns_)
+ { /* First entrypoint for this program unit. */
+ ent_num = 1;
+ mfn_num = ffecom_num_fns_;
+ ffecom_do_entry_ (ffecom_primary_entry_, 0);
+ }
+ else
+ ++ent_num;
- t = ffecom_vardesc_ (ffebld_head (b));
+ --ffecom_num_entrypoints_;
- 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);
- }
- }
+ ffecom_do_entry_ (entry, ent_num);
+}
- yes = suspend_momentary ();
+#endif
- 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;
+/* Essentially does a "fold (build (code, type, node1, node2))" while
+ checking for certain housekeeping things. Always sets
+ TREE_SIDE_EFFECTS. */
- var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
- mynumber++);
- var = build_decl (VAR_DECL, var, item);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
- var = start_decl (var, FALSE);
- finish_decl (var, list, FALSE);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_2s (enum tree_code code, tree type, tree node1,
+ tree node2)
+{
+ tree item;
- resume_momentary (yes);
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
- return var;
+ item = build (code, type, node1, node2);
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (item);
}
#endif
+/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
+ checking for certain housekeeping things. */
+
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_vardesc_dims_ (ffesymbol s)
+tree
+ffecom_3 (enum tree_code code, tree type, tree node1,
+ tree node2, tree node3)
{
- if (ffesymbol_dims (s) == NULL)
- return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
- integer_zero_node);
+ tree item;
- {
- ffebld b;
- ffebld e;
- tree list;
- tree backlist;
- tree item = NULL_TREE;
- tree var;
- int yes;
- tree numdim;
- tree numelem;
- tree baseoff = NULL_TREE;
- static int mynumber = 0;
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (node3 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
- numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
- TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_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);
+}
- numelem = ffecom_expr (ffesymbol_arraysize (s));
- TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
+#endif
+/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
+ checking for certain housekeeping things. Always sets
+ TREE_SIDE_EFFECTS. */
- 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 FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_3s (enum tree_code code, tree type, tree node1,
+ tree node2, tree node3)
+{
+ tree item;
- if (ffebld_trail (b) == NULL)
- t = NULL_TREE;
- else
- {
- t = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (ffebld_head (e)));
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (node3 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
- 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 (code, type, node1, node2, node3);
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (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);
+#endif
- back = build_tree_list (low, t);
- TREE_CHAIN (back) = backlist;
- backlist = back;
- }
+/* ffecom_arg_expr -- Transform argument expr into gcc tree
- 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));
- }
+ See use by ffecom_list_expr.
- /* backlist now dead, along with all TREE_PURPOSEs on it. */
+ If expression is NULL, returns an integer zero tree. If it is not
+ a CHARACTER expression, returns whatever ffecom_expr
+ returns and sets the length return value to NULL_TREE. Otherwise
+ generates code to evaluate the character expression, returns the proper
+ pointer to the result, but does NOT set the length return value to a tree
+ that specifies the length of the result. (In other words, the length
+ variable is always set to NULL_TREE, because a length is never passed.)
- baseoff = build_tree_list (NULL_TREE, baseoff);
- TREE_CHAIN (baseoff) = list;
+ 21-Dec-91 JCB 1.1
+ Don't set returned length, since nobody needs it (yet; someday if
+ we allow CHARACTER*(*) dummies to statement functions, we'll need
+ it). */
- numelem = build_tree_list (NULL_TREE, numelem);
- TREE_CHAIN (numelem) = baseoff;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_arg_expr (ffebld expr, tree *length)
+{
+ tree ign;
- numdim = build_tree_list (NULL_TREE, numdim);
- TREE_CHAIN (numdim) = numelem;
+ *length = NULL_TREE;
- yes = suspend_momentary ();
+ if (expr == NULL)
+ return integer_zero_node;
- 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;
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_expr (expr);
- var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
- mynumber++);
- var = build_decl (VAR_DECL, var, item);
- TREE_STATIC (var) = 1;
- DECL_INITIAL (var) = error_mark_node;
- var = start_decl (var, FALSE);
- finish_decl (var, list, FALSE);
+ return ffecom_arg_ptr_to_expr (expr, &ign);
+}
+
+#endif
+/* Transform expression into constant argument-pointer-to-expression tree.
+
+ If the expression can be transformed into a argument-pointer-to-expression
+ tree that is constant, that is done, and the tree returned. Else
+ NULL_TREE is returned.
- var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
- resume_momentary (yes);
+tree
+ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
+{
+ if (! expr)
+ return integer_zero_node;
- return var;
- }
+ 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;
}
-#endif
-/* Essentially does a "fold (build1 (code, type, node))" while checking
- for certain housekeeping things.
+/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
- NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
- ffecom_1_fn instead. */
+ See use by ffecom_list_ptr_to_expr.
+
+ If expression is NULL, returns an integer zero tree. If it is not
+ a CHARACTER expression, returns whatever ffecom_ptr_to_expr
+ returns and sets the length return value to NULL_TREE. Otherwise
+ generates code to evaluate the character expression, returns the proper
+ pointer to the result, AND sets the length return value to a tree that
+ specifies the length of the result.
+
+ If the length argument is NULL, this is a slightly special
+ case of building a FORMAT expression, that is, an expression that
+ will be used at run time without regard to length. For the current
+ implementation, which uses the libf2c library, this means it is nice
+ to append a null byte to the end of the expression, where feasible,
+ to make sure any diagnostic about the FORMAT string terminates at
+ some useful point.
+
+ For now, treat %REF(char-expr) as the same as char-expr with a NULL
+ length argument. This might even be seen as a feature, if a null
+ byte can always be appended. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_1 (enum tree_code code, tree type, tree node)
+ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
{
tree item;
+ tree ign_length;
+ ffecomConcatList_ catlist;
- if ((node == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
+ if (length != NULL)
+ *length = NULL_TREE;
- if (code == ADDR_EXPR)
- {
- if (!mark_addressable (node))
- assert ("can't mark_addressable this node!" == NULL);
- }
+ if (expr == NULL)
+ return integer_zero_node;
- switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
+ switch (ffebld_op (expr))
{
- tree realtype;
+ case FFEBLD_opPERCENT_VAL:
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_expr (ffebld_left (expr));
+ {
+ tree temp_exp;
+ tree temp_length;
- case REALPART_EXPR:
- item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
- break;
+ temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
+ if (temp_exp == error_mark_node)
+ return error_mark_node;
- case IMAGPART_EXPR:
- item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
- break;
+ 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 NEGATE_EXPR:
- if (TREE_CODE (type) != RECORD_TYPE)
+ case FFEBLD_opPERCENT_DESCR:
+ switch (ffeinfo_basictype (ffebld_info (expr)))
{
- item = build1 (code, type, node);
+#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
+ case FFEINFO_basictypeHOLLERITH:
+#endif
+ case FFEINFO_basictypeCHARACTER:
+ break; /* Passed by descriptor anyway. */
+
+ default:
+ item = ffecom_ptr_to_expr (expr);
+ if (item != error_mark_node)
+ *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
break;
}
- 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))
+#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
+ if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
+ && (length != NULL))
+ { /* Pass Hollerith by descriptor. */
+ ffetargetHollerith h;
+
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ h = ffebld_cu_val_hollerith (ffebld_constant_union
+ (ffebld_conter (expr)));
+ *length
+ = build_int_2 (h.length, 0);
+ TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+ }
+#endif
+
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_ptr_to_expr (expr);
+
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeCHARACTER1);
+
+ catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
+ switch (ffecom_concat_list_count_ (catlist))
+ {
+ case 0: /* Shouldn't happen, but in case it does... */
+ if (length != NULL)
+ {
+ *length = ffecom_f2c_ftnlen_zero_node;
+ TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+ }
+ ffecom_concat_list_kill_ (catlist);
+ return null_pointer_node;
+
+ case 1: /* The (fairly) easy case. */
+ if (length == NULL)
+ ffecom_char_args_with_null_ (&item, &ign_length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ else
+ ffecom_char_args_ (&item, length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ ffecom_concat_list_kill_ (catlist);
+ assert (item != NULL_TREE);
+ return item;
+
+ default: /* Must actually concatenate things. */
+ break;
+ }
+
+ {
+ int count = ffecom_concat_list_count_ (catlist);
+ int i;
+ tree lengths;
+ tree items;
+ tree length_array;
+ tree item_array;
+ tree citem;
+ tree clength;
+ tree temporary;
+ tree num;
+ tree known_length;
+ ffetargetCharacterSize sz;
+
+ sz = ffecom_concat_list_maxlen_ (catlist);
+ /* ~~Kludge! */
+ assert (sz != FFETARGET_charactersizeNONE);
+
+#ifdef HOHO
+ length_array
+ = lengths
+ = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
+ FFETARGET_charactersizeNONE, count, TRUE);
+ item_array
+ = items
+ = ffecom_push_tempvar (ffecom_f2c_address_type_node,
+ FFETARGET_charactersizeNONE, count, TRUE);
+ temporary = ffecom_push_tempvar (char_type_node,
+ sz, -1, TRUE);
+#else
+ {
+ 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);
+ }
+#endif
+
+ 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;
- if ((code == ADDR_EXPR) && staticp (node))
- TREE_CONSTANT (item) = 1;
- return fold (item);
+ 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;
}
+
#endif
+/* Generate call to run-time function.
-/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
- handles TREE_CODE (node) == FUNCTION_DECL. In particular,
- does not set TREE_ADDRESSABLE (because calling an inline
- function does not mean the function needs to be separately
- compiled). */
+ The first arg is the GNU Fortran Run-Time function index, the second
+ arg is the list of arguments to pass to it. Returned is the expression
+ (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
+ result (which may be void). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_1_fn (tree node)
+ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
{
- 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);
+ 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);
}
#endif
-/* Essentially does a "fold (build (code, type, node1, node2))" while
- checking for certain housekeeping things. */
+/* Transform constant-union to tree. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_2 (enum tree_code code, tree type, tree node1,
- tree node2)
+ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
+ ffeinfoKindtype kt, tree tree_type)
{
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)
+ switch (bt)
{
- 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 FFEINFO_basictypeINTEGER:
+ {
+ int val;
- 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;
+ switch (kt)
+ {
+#if FFETARGET_okINTEGER1
+ case FFEINFO_kindtypeINTEGER1:
+ val = ffebld_cu_val_integer1 (*cu);
+ break;
+#endif
- 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;
+#if FFETARGET_okINTEGER2
+ case FFEINFO_kindtypeINTEGER2:
+ val = ffebld_cu_val_integer2 (*cu);
+ break;
+#endif
- 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;
+#if FFETARGET_okINTEGER3
+ case FFEINFO_kindtypeINTEGER3:
+ val = ffebld_cu_val_integer3 (*cu);
+ break;
+#endif
- 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;
+#if FFETARGET_okINTEGER4
+ case FFEINFO_kindtypeINTEGER4:
+ val = ffebld_cu_val_integer4 (*cu);
+ break;
+#endif
- default:
- item = build (code, type, node1, node2);
+ default:
+ assert ("bad INTEGER constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ TREE_TYPE (item) = tree_type;
+ }
break;
- }
- if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
+ case FFEINFO_basictypeLOGICAL:
+ {
+ int val;
+ switch (kt)
+ {
+#if FFETARGET_okLOGICAL1
+ case FFEINFO_kindtypeLOGICAL1:
+ val = ffebld_cu_val_logical1 (*cu);
+ break;
#endif
-/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
-
- ffesymbol s; // the ENTRY point itself
- if (ffecom_2pass_advise_entrypoint(s))
- // the ENTRY point has been accepted
-
- Does whatever compiler needs to do when it learns about the entrypoint,
- like determine the return type of the master function, count the
- number of entrypoints, etc. Returns FALSE if the return type is
- not compatible with the return type(s) of other entrypoint(s).
- NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
- later (after _finish_progunit) be called with the same entrypoint(s)
- as passed to this fn for which TRUE was returned.
+#if FFETARGET_okLOGICAL2
+ case FFEINFO_kindtypeLOGICAL2:
+ val = ffebld_cu_val_logical2 (*cu);
+ break;
+#endif
- 03-Jan-92 JCB 2.0
- Return FALSE if the return type conflicts with previous entrypoints. */
+#if FFETARGET_okLOGICAL3
+ case FFEINFO_kindtypeLOGICAL3:
+ val = ffebld_cu_val_logical3 (*cu);
+ break;
+#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-bool
-ffecom_2pass_advise_entrypoint (ffesymbol entry)
-{
- ffebld list; /* opITEM. */
- ffebld mlist; /* opITEM. */
- ffebld plist; /* opITEM. */
- ffebld arg; /* ffebld_head(opITEM). */
- ffebld item; /* opITEM. */
- ffesymbol s; /* ffebld_symter(arg). */
- ffeinfoBasictype bt = ffesymbol_basictype (entry);
- ffeinfoKindtype kt = ffesymbol_kindtype (entry);
- ffetargetCharacterSize size = ffesymbol_size (entry);
- bool ok;
+#if FFETARGET_okLOGICAL4
+ case FFEINFO_kindtypeLOGICAL4:
+ val = ffebld_cu_val_logical4 (*cu);
+ break;
+#endif
- if (ffecom_num_entrypoints_ == 0)
- { /* First entrypoint, make list of main
- arglist's dummies. */
- assert (ffecom_primary_entry_ != NULL);
+ default:
+ assert ("bad LOGICAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ TREE_TYPE (item) = tree_type;
+ }
+ break;
- ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
- ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
- ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
+ case FFEINFO_basictypeREAL:
+ {
+ REAL_VALUE_TYPE val;
- for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue; /* Alternate return or some such thing. */
- item = ffebld_new_item (arg, NULL);
- if (plist == NULL)
- ffecom_master_arglist_ = item;
- else
- ffebld_set_trail (plist, item);
- plist = item;
- }
- }
+ switch (kt)
+ {
+#if FFETARGET_okREAL1
+ case FFEINFO_kindtypeREAL1:
+ val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
+ break;
+#endif
- /* If necessary, scan entry arglist for alternate returns. Do this scan
- apparently redundantly (it's done below to UNIONize the arglists) so
- that we don't complain about RETURN 1 if an offending ENTRY is the only
- one with an alternate return. */
+#if FFETARGET_okREAL2
+ case FFEINFO_kindtypeREAL2:
+ val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
+ break;
+#endif
- 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;
- }
- }
- }
+#if FFETARGET_okREAL3
+ case FFEINFO_kindtypeREAL3:
+ val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
+ break;
+#endif
- /* Now check type compatibility. */
+#if FFETARGET_okREAL4
+ case FFEINFO_kindtypeREAL4:
+ val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
+ break;
+#endif
- switch (ffecom_master_bt_)
- {
- case FFEINFO_basictypeNONE:
- ok = (bt != FFEINFO_basictypeCHARACTER);
+ default:
+ assert ("bad REAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_real (tree_type, val);
+ }
break;
- case FFEINFO_basictypeCHARACTER:
- ok
- = (bt == FFEINFO_basictypeCHARACTER)
- && (kt == ffecom_master_kt_)
- && (size == ffecom_master_size_);
- break;
+ case FFEINFO_basictypeCOMPLEX:
+ {
+ REAL_VALUE_TYPE real;
+ REAL_VALUE_TYPE imag;
+ tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
- case FFEINFO_basictypeANY:
- return FALSE; /* Just don't bother. */
+ 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
- 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 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 (!ok)
- {
- ffebad_start (FFEBAD_ENTRY_CONFLICTS);
- ffest_ffebad_here_current_stmt (0);
- ffebad_finish ();
- return FALSE; /* Can't handle entrypoint. */
- }
+#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
- /* Entrypoint type compatible with previous types. */
+#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
- ++ffecom_num_entrypoints_;
+ default:
+ assert ("bad REAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = ffecom_build_complex_constant_ (tree_type,
+ build_real (el_type, real),
+ build_real (el_type, imag));
+ }
+ break;
- /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
+ case FFEINFO_basictypeCHARACTER:
+ { /* Happens only in DATA and similar contexts. */
+ ffetargetCharacter1 val;
- for (list = ffesymbol_dummyargs (entry);
- list != NULL;
- list = ffebld_trail (list))
- {
- arg = ffebld_head (list);
- if (ffebld_op (arg) != FFEBLD_opSYMTER)
- continue; /* Alternate return or some such thing. */
- s = ffebld_symter (arg);
- for (plist = NULL, mlist = ffecom_master_arglist_;
- mlist != NULL;
- plist = mlist, mlist = ffebld_trail (mlist))
- { /* plist points to previous item for easy
- appending of arg. */
- if (ffebld_symter (ffebld_head (mlist)) == s)
- break; /* Already have this arg in the master list. */
- }
- if (mlist != NULL)
- continue; /* Already have this arg in the master list. */
+ switch (kt)
+ {
+#if FFETARGET_okCHARACTER1
+ case FFEINFO_kindtypeLOGICAL1:
+ val = ffebld_cu_val_character1 (*cu);
+ break;
+#endif
+
+ default:
+ assert ("bad CHARACTER constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_string (ffetarget_length_character1 (val),
+ ffetarget_text_character1 (val));
+ TREE_TYPE (item)
+ = build_type_variant (build_array_type (char_type_node,
+ build_range_type
+ (integer_type_node,
+ integer_one_node,
+ build_int_2
+ (ffetarget_length_character1
+ (val), 0))),
+ 1, 0);
+ }
+ break;
- /* Append this arg to the master list. */
+ case FFEINFO_basictypeHOLLERITH:
+ {
+ ffetargetHollerith h;
- item = ffebld_new_item (arg, NULL);
- if (plist == NULL)
- ffecom_master_arglist_ = item;
- else
- ffebld_set_trail (plist, item);
- }
+ h = ffebld_cu_val_hollerith (*cu);
- return TRUE;
-}
+ /* If not at least as wide as default INTEGER, widen it. */
+ if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
+ item = build_string (h.length, h.text);
+ else
+ {
+ char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
-#endif
-/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
+ 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;
- ffesymbol s; // the ENTRY point itself
- ffecom_2pass_do_entrypoint(s);
+ case FFEINFO_basictypeTYPELESS:
+ {
+ ffetargetInteger1 ival;
+ ffetargetTypeless tless;
+ ffebad error;
- Does whatever compiler needs to do to make the entrypoint actually
- happen. Must be called for each entrypoint after
- ffecom_finish_progunit is called. */
+ tless = ffebld_cu_val_typeless (*cu);
+ error = ffetarget_convert_integer1_typeless (&ival, tless);
+ assert (error == FFEBAD);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_2pass_do_entrypoint (ffesymbol entry)
-{
- static int mfn_num = 0;
- static int ent_num;
+ item = build_int_2 ((int) ival, 0);
+ }
+ break;
- if (mfn_num != ffecom_num_fns_)
- { /* First entrypoint for this program unit. */
- ent_num = 1;
- mfn_num = ffecom_num_fns_;
- ffecom_do_entry_ (ffecom_primary_entry_, 0);
+ default:
+ assert ("not yet on constant type" == NULL);
+ /* Fall through. */
+ case FFEINFO_basictypeANY:
+ return error_mark_node;
}
- else
- ++ent_num;
- --ffecom_num_entrypoints_;
+ TREE_CONSTANT (item) = 1;
- ffecom_do_entry_ (entry, ent_num);
+ return item;
}
#endif
-/* Essentially does a "fold (build (code, type, node1, node2))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
+/* Transform expression into constant tree.
+
+ If the expression can be transformed into a tree that is constant,
+ that is done, and the tree returned. Else NULL_TREE is returned.
+
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_2s (enum tree_code code, tree type, tree node1,
- tree node2)
+ffecom_const_expr (ffebld expr)
{
- tree item;
+ if (! expr)
+ return integer_zero_node;
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (type == error_mark_node))
+ if (ffebld_op (expr) == FFEBLD_opANY)
return error_mark_node;
- item = build (code, type, node1, node2);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
-
+ if (ffebld_arity (expr) == 0
+ && (ffebld_op (expr) != FFEBLD_opSYMTER
+#if NEWCOMMON
+ /* ~~Enable once common/equivalence is handled properly? */
+ || ffebld_where (expr) == FFEINFO_whereCOMMON
#endif
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_3 (enum tree_code code, tree type, tree node1,
- tree node2, tree node3)
-{
- tree item;
+ || ffebld_where (expr) == FFEINFO_whereGLOBAL
+ || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
+ {
+ tree t;
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
+ t = ffecom_expr (expr);
+ assert (TREE_CONSTANT (t));
+ return t;
+ }
- 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);
+ return NULL_TREE;
}
-#endif
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
+/* Handy way to make a field in a struct/union. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_3s (enum tree_code code, tree type, tree node1,
- tree node2, tree node3)
+ffecom_decl_field (tree context, tree prevfield,
+ const char *name, tree type)
{
- tree item;
+ tree field;
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
+ field = build_decl (FIELD_DECL, get_identifier (name), type);
+ DECL_CONTEXT (field) = context;
+ DECL_FRAME_SIZE (field) = 0;
+ if (prevfield != NULL_TREE)
+ TREE_CHAIN (prevfield) = field;
- item = build (code, type, node1, node2, node3);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
+ return field;
}
#endif
-/* ffecom_arg_expr -- Transform argument expr into gcc tree
- See use by ffecom_list_expr.
+void
+ffecom_close_include (FILE *f)
+{
+#if FFECOM_GCC_INCLUDE
+ ffecom_close_include_ (f);
+#endif
+}
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, but does NOT set the length return value to a tree
- that specifies the length of the result. (In other words, the length
- variable is always set to NULL_TREE, because a length is never passed.)
+int
+ffecom_decode_include_option (char *spec)
+{
+#if FFECOM_GCC_INCLUDE
+ return ffecom_decode_include_option_ (spec);
+#else
+ return 1;
+#endif
+}
- 21-Dec-91 JCB 1.1
- Don't set returned length, since nobody needs it (yet; someday if
- we allow CHARACTER*(*) dummies to statement functions, we'll need
- it). */
+/* End a compound statement (block). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_arg_expr (ffebld expr, tree *length)
+ffecom_end_compstmt (void)
{
- tree ign;
-
- *length = NULL_TREE;
+ return bison_rule_compstmt_ ();
+}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
- if (expr == NULL)
- return integer_zero_node;
+/* ffecom_end_transition -- Perform end transition on all symbols
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_expr (expr);
+ ffecom_end_transition();
- return ffecom_arg_ptr_to_expr (expr, &ign);
-}
+ Calls ffecom_sym_end_transition for each global and local symbol. */
+void
+ffecom_end_transition ()
+{
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffebld item;
#endif
-/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
-
- See use by ffecom_list_ptr_to_expr.
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_ptr_to_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, AND sets the length return value to a tree that
- specifies the length of the result.
+ if (ffe_is_ffedebug ())
+ fprintf (dmpout, "; end_stmt_transition\n");
- If the length argument is NULL, this is a slightly special
- case of building a FORMAT expression, that is, an expression that
- will be used at run time without regard to length. For the current
- implementation, which uses the libf2c library, this means it is nice
- to append a null byte to the end of the expression, where feasible,
- to make sure any diagnostic about the FORMAT string terminates at
- some useful point.
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffecom_list_blockdata_ = NULL;
+ ffecom_list_common_ = NULL;
+#endif
- For now, treat %REF(char-expr) as the same as char-expr with a NULL
- length argument. This might even be seen as a feature, if a null
- byte can always be appended. */
+ ffesymbol_drive (ffecom_sym_end_transition);
+ if (ffe_is_ffedebug ())
+ {
+ ffestorag_report ();
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffesymbol_report_all ();
+#endif
+ }
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
-{
- tree item;
- tree ign_length;
- ffecomConcatList_ catlist;
+ ffecom_start_progunit_ ();
+
+ for (item = ffecom_list_blockdata_;
+ item != NULL;
+ item = ffebld_trail (item))
+ {
+ ffebld callee;
+ ffesymbol s;
+ tree dt;
+ tree t;
+ tree var;
+ int yes;
+ static int number = 0;
+
+ callee = ffebld_head (item);
+ s = ffebld_symter (callee);
+ t = ffesymbol_hook (s).decl_tree;
+ if (t == NULL_TREE)
+ {
+ s = ffecom_sym_transform_ (s);
+ t = ffesymbol_hook (s).decl_tree;
+ }
- if (length != NULL)
- *length = NULL_TREE;
+ yes = suspend_momentary ();
- if (expr == NULL)
- return integer_zero_node;
+ dt = build_pointer_type (TREE_TYPE (t));
- 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;
+ var = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_forceload_%d",
+ NULL, number++),
+ dt);
+ DECL_EXTERNAL (var) = 0;
+ TREE_STATIC (var) = 1;
+ TREE_PUBLIC (var) = 0;
+ DECL_INITIAL (var) = error_mark_node;
+ TREE_USED (var) = 1;
- temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
- if (temp_exp == error_mark_node)
- return error_mark_node;
+ var = start_decl (var, FALSE);
- return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
- temp_exp);
- }
+ t = ffecom_1 (ADDR_EXPR, dt, t);
- 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;
+ finish_decl (var, t, FALSE);
- case FFEBLD_opPERCENT_DESCR:
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- case FFEINFO_basictypeHOLLERITH:
+ resume_momentary (yes);
+ }
+
+ /* This handles any COMMON areas that weren't referenced but have, for
+ example, important initial data. */
+
+ for (item = ffecom_list_common_;
+ item != NULL;
+ item = ffebld_trail (item))
+ ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
+
+ ffecom_list_common_ = NULL;
#endif
- case FFEINFO_basictypeCHARACTER:
- break; /* Passed by descriptor anyway. */
+}
- default:
- item = ffecom_ptr_to_expr (expr);
- if (item != error_mark_node)
- *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
- break;
- }
- break;
+/* ffecom_exec_transition -- Perform exec transition on all symbols
- default:
- break;
- }
+ ffecom_exec_transition();
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
- && (length != NULL))
- { /* Pass Hollerith by descriptor. */
- ffetargetHollerith h;
+ Calls ffecom_sym_exec_transition for each global and local symbol.
+ Make sure error updating not inhibited. */
- 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
+void
+ffecom_exec_transition ()
+{
+ bool inhibited;
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_ptr_to_expr (expr);
+ if (ffe_is_ffedebug ())
+ fprintf (dmpout, "; exec_stmt_transition\n");
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeCHARACTER1);
+ inhibited = ffebad_inhibit ();
+ ffebad_set_inhibit (FALSE);
- catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
- switch (ffecom_concat_list_count_ (catlist))
+ ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
+ ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
+ if (ffe_is_ffedebug ())
{
- case 0: /* Shouldn't happen, but in case it does... */
- if (length != NULL)
- {
- *length = ffecom_f2c_ftnlen_zero_node;
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
- ffecom_concat_list_kill_ (catlist);
- return null_pointer_node;
+ ffestorag_report ();
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffesymbol_report_all ();
+#endif
+ }
- case 1: /* The (fairly) easy case. */
- if (length == NULL)
- ffecom_char_args_with_null_ (&item, &ign_length,
- ffecom_concat_list_expr_ (catlist, 0));
- else
- ffecom_char_args_ (&item, length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
- return item;
+ if (inhibited)
+ ffebad_set_inhibit (TRUE);
+}
- default: /* Must actually concatenate things. */
- break;
- }
+/* Handle assignment statement.
- {
- 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;
+ Convert dest and source using ffecom_expr, then join them
+ with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
- length_array
- = lengths
- = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
- item_array
- = items
- = ffecom_push_tempvar (ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_expand_let_stmt (ffebld dest, ffebld source)
+{
+ tree dest_tree;
+ tree dest_length;
+ tree source_tree;
+ tree expr_tree;
- known_length = ffecom_f2c_ftnlen_zero_node;
+ if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
+ {
+ bool dest_used;
- 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;
- }
+ /* This attempts to replicate the test below, but must not be
+ true when the test below is false. (Always err on the side
+ of creating unused temporaries, to avoid ICEs.) */
+ if (ffebld_op (dest) != FFEBLD_opSYMTER
+ || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
+ && (TREE_CODE (dest_tree) != VAR_DECL
+ || TREE_ADDRESSABLE (dest_tree))))
+ {
+ ffecom_prepare_expr_ (source, dest);
+ dest_used = TRUE;
+ }
+ else
+ {
+ ffecom_prepare_expr_ (source, NULL);
+ dest_used = FALSE;
+ }
- 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);
- }
+ ffecom_prepare_expr_w (NULL_TREE, dest);
- sz = ffecom_concat_list_maxlen_ (catlist);
- assert (sz != FFETARGET_charactersizeNONE);
+ ffecom_prepare_end ();
- temporary = ffecom_push_tempvar (char_type_node,
- sz, -1, TRUE);
- temporary = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (temporary)),
- temporary);
+ dest_tree = ffecom_expr_w (NULL_TREE, dest);
+ if (dest_tree == error_mark_node)
+ return;
- 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);
+ 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;
- item = ffecom_call_gfrt (FFECOM_gfrtCAT, item);
- TREE_SIDE_EFFECTS (item) = 1;
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
- item,
- temporary);
+ if (dest_used)
+ expr_tree = source_tree;
+ else
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ dest_tree,
+ source_tree);
- if (length != NULL)
- *length = known_length;
- }
+ expand_expr_stmt (expr_tree);
+ return;
+ }
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
- return item;
+ 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);
}
#endif
-/* ffecom_call_gfrt -- Generate call to run-time function
+/* ffecom_expr -- Transform expr into gcc tree
- tree expr;
- expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
+ tree t;
+ ffebld expr; // FFE expression.
+ tree = ffecom_expr(expr);
- The first arg is the GNU Fortran Run-Time function index, the second
- arg is the list of arguments to pass to it. Returned is the expression
- (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
- result (which may be void). */
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_call_gfrt (ffecomGfrt ix, tree args)
+ffecom_expr (ffebld expr)
{
- 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);
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
}
+
#endif
+/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
-/* ffecom_constantunion -- Transform constant-union to tree
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_assign (ffebld expr)
+{
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
+}
- ffebldConstantUnion cu; // the constant to transform
- ffeinfoBasictype bt; // its basic type
- ffeinfoKindtype kt; // its kind type
- tree tree_type; // ffecom_tree_type[bt][kt]
- ffecom_constantunion(&cu,bt,kt,tree_type); */
+#endif
+/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
- ffeinfoKindtype kt, tree tree_type)
+ffecom_expr_assign_w (ffebld expr)
{
- tree item;
-
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- {
- int val;
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
+}
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- val = ffebld_cu_val_integer1 (*cu);
- break;
#endif
+/* Transform expr for use as into read/write tree and stabilize the
+ reference. Not for use on CHARACTER expressions.
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- val = ffebld_cu_val_integer2 (*cu);
- break;
-#endif
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- val = ffebld_cu_val_integer3 (*cu);
- break;
-#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_rw (tree type, ffebld expr)
+{
+ assert (expr != NULL);
+ /* Different target types not yet supported. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
+
+ return stabilize_reference (ffecom_expr (expr));
+}
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- val = ffebld_cu_val_integer4 (*cu);
- break;
#endif
+/* Transform expr for use as into write tree and stabilize the
+ reference. Not for use on CHARACTER expressions.
- default:
- assert ("bad INTEGER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- TREE_TYPE (item) = tree_type;
- }
- break;
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
- case FFEINFO_basictypeLOGICAL:
- {
- int val;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_w (tree type, ffebld expr)
+{
+ assert (expr != NULL);
+ /* Different target types not yet supported. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
+
+ return stabilize_reference (ffecom_expr (expr));
+}
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_logical1 (*cu);
- break;
#endif
+/* Do global stuff. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_finish_compile ()
+{
+ assert (ffecom_outer_function_decl_ == NULL_TREE);
+ assert (current_function_decl == NULL_TREE);
+
+ ffeglobal_drive (ffecom_finish_global_);
+}
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- val = ffebld_cu_val_logical2 (*cu);
- break;
#endif
+/* Public entry point for front end to access finish_decl. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_finish_decl (tree decl, tree init, bool is_top_level)
+{
+ assert (!is_top_level);
+ finish_decl (decl, init, FALSE);
+}
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- val = ffebld_cu_val_logical3 (*cu);
- break;
#endif
+/* Finish a program unit. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_finish_progunit ()
+{
+ ffecom_end_compstmt ();
+
+ ffecom_previous_function_decl_ = current_function_decl;
+ ffecom_which_entrypoint_decl_ = NULL_TREE;
+
+ finish_function (0);
+}
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- val = ffebld_cu_val_logical4 (*cu);
- break;
#endif
+/* Wrapper for get_identifier. pattern is sprintf-like, assumed to contain
+ one %s if text is not NULL, assumed to contain one %d if number is
+ not -1. If both are assumed, the %s is assumed to precede the %d. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_get_invented_identifier (const char *pattern, const char *text,
+ int number)
+{
+ tree decl;
+ char *nam;
+ mallocSize lenlen;
+ char space[66];
+
+ lenlen = 0;
+ if (text)
+ lenlen += strlen (text);
+ if (number != -1)
+ lenlen += 20;
+ if (text || number != -1)
+ {
+ lenlen += strlen (pattern);
+ if (lenlen > ARRAY_SIZE (space))
+ nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
+ else
+ nam = &space[0];
+ }
+ else
+ {
+ lenlen = 0;
+ nam = (char *) pattern;
+ }
+
+ if (text == NULL)
+ {
+ if (number != -1)
+ sprintf (&nam[0], pattern, number);
+ }
+ else
+ {
+ if (number == -1)
+ sprintf (&nam[0], pattern, text);
+ else
+ sprintf (&nam[0], pattern, text, number);
+ }
+
+ decl = get_identifier (nam);
+
+ if (lenlen > ARRAY_SIZE (space))
+ malloc_kill_ks (malloc_pool_image (), nam, lenlen);
+
+ IDENTIFIER_INVENTED (decl) = 1;
+
+ return decl;
+}
+
+ffeinfoBasictype
+ffecom_gfrt_basictype (ffecomGfrt gfrt)
+{
+ assert (gfrt < FFECOM_gfrt);
+
+ switch (ffecom_gfrt_type_[gfrt])
+ {
+ case FFECOM_rttypeVOID_:
+ 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;
- default:
- assert ("bad LOGICAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- TREE_TYPE (item) = tree_type;
- }
- break;
+ case FFECOM_rttypeFTNINT_:
+ return FFEINFO_kindtypeINTEGER1;
- case FFEINFO_basictypeREAL:
- {
- REAL_VALUE_TYPE val;
+ case FFECOM_rttypeINTEGER_:
+ return FFEINFO_kindtypeINTEGER1;
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
- break;
-#endif
+ case FFECOM_rttypeLONGINT_:
+ return FFEINFO_kindtypeINTEGER4;
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
- break;
-#endif
+ case FFECOM_rttypeLOGICAL_:
+ return FFEINFO_kindtypeLOGICAL1;
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
- break;
-#endif
+ case FFECOM_rttypeREAL_F2C_:
+ case FFECOM_rttypeREAL_GNU_:
+ return FFEINFO_kindtypeREAL1;
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
- break;
-#endif
+ case FFECOM_rttypeCOMPLEX_F2C_:
+ case FFECOM_rttypeCOMPLEX_GNU_:
+ return FFEINFO_kindtypeREAL1;
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_real (tree_type, val);
- }
- break;
+ case FFECOM_rttypeDOUBLE_:
+ case FFECOM_rttypeDOUBLEREAL_:
+ return FFEINFO_kindtypeREAL2;
- case FFEINFO_basictypeCOMPLEX:
- {
- REAL_VALUE_TYPE real;
- REAL_VALUE_TYPE imag;
- tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
+ case FFECOM_rttypeDBLCMPLX_F2C_:
+ case FFECOM_rttypeDBLCMPLX_GNU_:
+ return FFEINFO_kindtypeREAL2;
- 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
+ case FFECOM_rttypeCHARACTER_:
+ return FFEINFO_kindtypeCHARACTER1;
-#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
+ default:
+ return FFEINFO_kindtypeANY;
+ }
+}
-#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
+void
+ffecom_init_0 ()
+{
+ tree endlink;
+ int i;
+ int j;
+ tree t;
+ tree field;
+ ffetype type;
+ ffetype base_type;
-#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
+ /* This block of code comes from the now-obsolete cktyps.c. It checks
+ whether the compiler environment is buggy in known ways, some of which
+ would, if not explicitly checked here, result in subtle bugs in g77. */
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = ffecom_build_complex_constant_ (tree_type,
- build_real (el_type, real),
- build_real (el_type, imag));
- }
- break;
+ if (ffe_is_do_internal_checks ())
+ {
+ static char names[][12]
+ =
+ {"bar", "bletch", "foo", "foobar"};
+ char *name;
+ unsigned long ul;
+ double fl;
- case FFEINFO_basictypeCHARACTER:
- { /* Happens only in DATA and similar contexts. */
- ffetargetCharacter1 val;
+ name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
+ (int (*)()) strcmp);
+ if (name != (char *) &names[2])
+ {
+ assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
+ == NULL);
+ abort ();
+ }
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_character1 (*cu);
- break;
-#endif
+ ul = strtoul ("123456789", NULL, 10);
+ if (ul != 123456789L)
+ {
+ assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
+ in proj.h" == NULL);
+ abort ();
+ }
- default:
- assert ("bad CHARACTER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_string (ffetarget_length_character1 (val),
- ffetarget_text_character1 (val));
- TREE_TYPE (item)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2
- (ffetarget_length_character1
- (val), 0))),
- 1, 0);
- }
- break;
+ fl = atof ("56.789");
+ if ((fl < 56.788) || (fl > 56.79))
+ {
+ assert ("atof not type double, fix your #include <stdio.h>"
+ == NULL);
+ abort ();
+ }
+ }
- case FFEINFO_basictypeHOLLERITH:
- {
- ffetargetHollerith h;
+ /* Set the sizetype before we do anything else. This _should_ be the
+ first type we create. */
- h = ffebld_cu_val_hollerith (*cu);
+ t = make_unsigned_type (POINTER_SIZE);
+ assert (t == sizetype);
- /* If not at least as wide as default INTEGER, widen it. */
- if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
- item = build_string (h.length, h.text);
- else
- {
- char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
+#if FFECOM_GCC_INCLUDE
+ ffecom_initialize_char_syntax_ ();
+#endif
- 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;
+ ffecom_outer_function_decl_ = NULL_TREE;
+ current_function_decl = NULL_TREE;
+ named_labels = NULL_TREE;
+ current_binding_level = NULL_BINDING_LEVEL;
+ free_binding_level = NULL_BINDING_LEVEL;
+ /* Make the binding_level structure for global names. */
+ pushlevel (0);
+ global_binding_level = current_binding_level;
+ current_binding_level->prep_state = 2;
- case FFEINFO_basictypeTYPELESS:
- {
- ffetargetInteger1 ival;
- ffetargetTypeless tless;
- ffebad error;
+ /* Define `int' and `char' first so that dbx will output them first. */
- tless = ffebld_cu_val_typeless (*cu);
- error = ffetarget_convert_integer1_typeless (&ival, tless);
- assert (error == FFEBAD);
+ integer_type_node = make_signed_type (INT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
+ integer_type_node));
- item = build_int_2 ((int) ival, 0);
- }
- break;
+ char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
+ char_type_node));
- default:
- assert ("not yet on constant type" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
+ long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
+ long_integer_type_node));
- TREE_CONSTANT (item) = 1;
+ unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
+ unsigned_type_node));
- return item;
-}
+ long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
+ long_unsigned_type_node));
-#endif
+ long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
+ long_long_integer_type_node));
-/* Handy way to make a field in a struct/union. */
+ long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
+ long_long_unsigned_type_node));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_decl_field (tree context, tree prevfield,
- const char *name, tree type)
-{
- tree field;
+ error_mark_node = make_node (ERROR_MARK);
+ TREE_TYPE (error_mark_node) = error_mark_node;
- field = build_decl (FIELD_DECL, get_identifier (name), type);
- DECL_CONTEXT (field) = context;
- DECL_FRAME_SIZE (field) = 0;
- if (prevfield != NULL_TREE)
- TREE_CHAIN (prevfield) = field;
+ short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
+ short_integer_type_node));
- return field;
-}
+ short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
+ short_unsigned_type_node));
-#endif
+ /* Define both `signed char' and `unsigned char'. */
+ signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
+ signed_char_type_node));
-void
-ffecom_close_include (FILE *f)
-{
-#if FFECOM_GCC_INCLUDE
- ffecom_close_include_ (f);
-#endif
-}
+ unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
+ unsigned_char_type_node));
-int
-ffecom_decode_include_option (char *spec)
-{
-#if FFECOM_GCC_INCLUDE
- return ffecom_decode_include_option_ (spec);
-#else
- return 1;
-#endif
-}
+ float_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
+ layout_type (float_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
+ float_type_node));
-/* ffecom_end_transition -- Perform end transition on all symbols
+ double_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
+ layout_type (double_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
+ double_type_node));
- ffecom_end_transition();
+ long_double_type_node = make_node (REAL_TYPE);
+ TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
+ layout_type (long_double_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
+ long_double_type_node));
- Calls ffecom_sym_end_transition for each global and local symbol. */
+ complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
+ complex_integer_type_node));
-void
-ffecom_end_transition ()
-{
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffebld item;
-#endif
+ complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
+ complex_float_type_node));
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; end_stmt_transition\n");
+ complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
+ complex_double_type_node));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffecom_list_blockdata_ = NULL;
- ffecom_list_common_ = NULL;
-#endif
+ complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
+ complex_long_double_type_node));
- ffesymbol_drive (ffecom_sym_end_transition);
- if (ffe_is_ffedebug ())
- {
- ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
- }
+ integer_zero_node = build_int_2 (0, 0);
+ TREE_TYPE (integer_zero_node) = integer_type_node;
+ integer_one_node = build_int_2 (1, 0);
+ TREE_TYPE (integer_one_node) = integer_type_node;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffecom_start_progunit_ ();
+ size_zero_node = build_int_2 (0, 0);
+ TREE_TYPE (size_zero_node) = sizetype;
+ size_one_node = build_int_2 (1, 0);
+ TREE_TYPE (size_one_node) = sizetype;
- for (item = ffecom_list_blockdata_;
- item != NULL;
- item = ffebld_trail (item))
- {
- ffebld callee;
- ffesymbol s;
- tree dt;
- tree t;
- tree var;
- int yes;
- static int number = 0;
+ void_type_node = make_node (VOID_TYPE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
+ void_type_node));
+ layout_type (void_type_node); /* Uses integer_zero_node */
+ /* We are not going to have real types in C with less than byte alignment,
+ so we might as well not have any types that claim to have it. */
+ TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
- 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;
- }
+ null_pointer_node = build_int_2 (0, 0);
+ TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
+ layout_type (TREE_TYPE (null_pointer_node));
- yes = suspend_momentary ();
+ string_type_node = build_pointer_type (char_type_node);
- dt = build_pointer_type (TREE_TYPE (t));
+ ffecom_tree_fun_type_void
+ = build_function_type (void_type_node, NULL_TREE);
- var = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_forceload_%d",
- NULL, number++),
- dt);
- DECL_EXTERNAL (var) = 0;
- TREE_STATIC (var) = 1;
- TREE_PUBLIC (var) = 0;
- DECL_INITIAL (var) = error_mark_node;
- TREE_USED (var) = 1;
+ ffecom_tree_ptr_to_fun_type_void
+ = build_pointer_type (ffecom_tree_fun_type_void);
- var = start_decl (var, FALSE);
+ endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
- t = ffecom_1 (ADDR_EXPR, dt, t);
+ float_ftype_float
+ = build_function_type (float_type_node,
+ tree_cons (NULL_TREE, float_type_node, endlink));
- finish_decl (var, t, FALSE);
+ double_ftype_double
+ = build_function_type (double_type_node,
+ tree_cons (NULL_TREE, double_type_node, endlink));
- resume_momentary (yes);
- }
+ ldouble_ftype_ldouble
+ = build_function_type (long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node,
+ endlink));
- /* This handles any COMMON areas that weren't referenced but have, for
- example, important initial data. */
+ 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;
+ }
- for (item = ffecom_list_common_;
- item != NULL;
- item = ffebld_trail (item))
- ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
+ /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
+ to size FLOAT_TYPE_SIZE because they have to be the same size as
+ REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
+ Compiler options and other such stuff that change the ways these
+ types are set should not affect this particular setup. */
- ffecom_list_common_ = NULL;
-#endif
-}
+ ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
+ = t = make_signed_type (FLOAT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
+ t));
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 1, type);
+ assert (ffetype_size (type) == sizeof (ffetargetInteger1));
-/* ffecom_exec_transition -- Perform exec transition on all symbols
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
+ = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
+ t));
- ffecom_exec_transition();
+ 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));
- Calls ffecom_sym_exec_transition for each global and local symbol.
- Make sure error updating not inhibited. */
+ 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));
-void
-ffecom_exec_transition ()
-{
- bool inhibited;
+ 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));
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; exec_stmt_transition\n");
+ 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));
- inhibited = ffebad_inhibit ();
- ffebad_set_inhibit (FALSE);
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
+ = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
+ t));
- ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
- ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
- if (ffe_is_ffedebug ())
+#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)
{
- ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
+ fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
+ LONG_TYPE_SIZE);
}
+#endif
- if (inhibited)
- ffebad_set_inhibit (TRUE);
-}
-
-/* ffecom_expand_let_stmt -- Compile let (assignment) statement
-
- ffebld dest;
- ffebld source;
- ffecom_expand_let_stmt(dest,source);
+ 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));
- Convert dest and source using ffecom_expr, then join them
- with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
+ 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));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_expand_let_stmt (ffebld dest, ffebld source)
-{
- tree dest_tree;
- tree dest_length;
- tree source_tree;
- tree expr_tree;
+ 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));
- if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
- {
- bool dest_used;
+ 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));
- dest_tree = ffecom_expr_rw (dest);
- if (dest_tree == error_mark_node)
- return;
+ 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));
- if ((TREE_CODE (dest_tree) != VAR_DECL)
- || TREE_ADDRESSABLE (dest_tree))
- source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
- FALSE, FALSE);
- else
- {
- source_tree = ffecom_expr (source);
- dest_used = FALSE;
- }
- if (source_tree == error_mark_node)
- return;
+ ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
+ = t = make_node (REAL_TYPE);
+ TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
+ t));
+ layout_type (t);
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 2, type);
+ ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
+ = FFETARGET_f2cTYDREAL;
+ assert (ffetype_size (type) == sizeof (ffetargetReal2));
- if (dest_used)
- expr_tree = source_tree;
- else
- expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
- dest_tree,
- source_tree);
+ 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));
- expand_expr_stmt (expr_tree);
- return;
- }
+ 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));
- ffecom_push_calltemps ();
- ffecom_char_args_ (&dest_tree, &dest_length, dest);
- ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
- source);
- ffecom_pop_calltemps ();
-}
+ /* Make function and ptr-to-function types for non-CHARACTER types. */
-#endif
-/* ffecom_expr -- Transform expr into gcc 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)
+ {
+ if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
+ {
+ if (i == FFEINFO_basictypeINTEGER)
+ {
+ /* Figure out the smallest INTEGER type that can hold
+ a pointer on this machine. */
+ if (GET_MODE_SIZE (TYPE_MODE (t))
+ >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
+ {
+ if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
+ || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
+ > GET_MODE_SIZE (TYPE_MODE (t))))
+ ffecom_pointer_kind_ = j;
+ }
+ }
+ else if (i == FFEINFO_basictypeCOMPLEX)
+ t = void_type_node;
+ /* For f2c compatibility, REAL functions are really
+ implemented as DOUBLE PRECISION. */
+ else if ((i == FFEINFO_basictypeREAL)
+ && (j == FFEINFO_kindtypeREAL1))
+ t = ffecom_tree_type
+ [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_expr(expr);
+ 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);
+ }
+ }
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
+ /* Set up pointer types. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
-}
+ if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
+ fatal ("no INTEGER type can hold a pointer on this configuration");
+ else if (0 && ffe_is_do_internal_checks ())
+ fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
+ ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT),
+ 7,
+ ffeinfo_type (FFEINFO_basictypeINTEGER,
+ ffecom_pointer_kind_));
-#endif
-/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
+ if (ffe_is_ugly_assign ())
+ ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
+ else
+ ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
+ if (0 && ffe_is_do_internal_checks ())
+ fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_assign (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
-}
+ 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);
-#endif
-/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
+ /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
+ Turns out that by TYLONG, runtime/libI77/lio.h really means
+ "whatever size an ftnint is". For consistency and sanity,
+ com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
+ all are INTEGER, which we also make out of whatever back-end
+ integer type is FLOAT_TYPE_SIZE bits wide. This change, from
+ LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
+ accommodate machines like the Alpha. Note that this suggests
+ f2c and libf2c are missing a distinction perhaps needed on
+ some machines between "int" and "long int". -- burley 0.5.5 950215 */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_assign_w (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
-}
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
+ FFETARGET_f2cTYLONG);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
+ FFETARGET_f2cTYSHORT);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
+ FFETARGET_f2cTYINT1);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
+ FFETARGET_f2cTYQUAD);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL2);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL1);
+ /* ~~~Not really such a type in libf2c, e.g. I/O support? */
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
+ FFETARGET_f2cTYQUAD);
-#endif
-/* Transform expr for use as into read/write tree and stabilize the
- reference. Not for use on CHARACTER expressions.
+ /* CHARACTER stuff is all special-cased, so it is not handled in the above
+ loop. CHARACTER items are built as arrays of unsigned char. */
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
+ 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]));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_rw (ffebld expr)
-{
- assert (expr != NULL);
+ 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;
- return stabilize_reference (ffecom_expr (expr));
-}
+ ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
+ = 0;
-#endif
-/* Do global stuff. */
+ /* Make multi-return-value type and fields. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_compile ()
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
+ ffecom_multi_type_node_ = make_node (UNION_TYPE);
- ffeglobal_drive (ffecom_finish_global_);
-}
+ field = NULL_TREE;
-#endif
-/* Public entry point for front end to access finish_decl. */
+ 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_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_decl (tree decl, tree init, bool is_top_level)
-{
- assert (!is_top_level);
- finish_decl (decl, init, FALSE);
-}
+ if (ffecom_tree_type[i][j] == NULL_TREE)
+ continue; /* Not supported. */
+ sprintf (&name[0], "bt_%s_kt_%s",
+ ffeinfo_basictype_string ((ffeinfoBasictype) i),
+ ffeinfo_kindtype_string ((ffeinfoKindtype) j));
+ ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
+ get_identifier (name),
+ ffecom_tree_type[i][j]);
+ DECL_CONTEXT (ffecom_multi_fields_[i][j])
+ = ffecom_multi_type_node_;
+ DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
+ TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
+ field = ffecom_multi_fields_[i][j];
+ }
-#endif
-/* Finish a program unit. */
+ TYPE_FIELDS (ffecom_multi_type_node_) = field;
+ layout_type (ffecom_multi_type_node_);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_progunit ()
-{
- ffecom_end_compstmt_ ();
+ /* Subroutines usually return integer because they might have alternate
+ returns. */
- ffecom_previous_function_decl_ = current_function_decl;
- ffecom_which_entrypoint_decl_ = NULL_TREE;
+ 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);
- finish_function (0);
-}
+ builtin_function ("__builtin_sqrtf", float_ftype_float,
+ BUILT_IN_FSQRT, "sqrtf");
+ builtin_function ("__builtin_fsqrt", double_ftype_double,
+ BUILT_IN_FSQRT, "sqrt");
+ builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
+ BUILT_IN_FSQRT, "sqrtl");
+ builtin_function ("__builtin_sinf", float_ftype_float,
+ BUILT_IN_SIN, "sinf");
+ builtin_function ("__builtin_sin", double_ftype_double,
+ BUILT_IN_SIN, "sin");
+ builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
+ BUILT_IN_SIN, "sinl");
+ builtin_function ("__builtin_cosf", float_ftype_float,
+ BUILT_IN_COS, "cosf");
+ builtin_function ("__builtin_cos", double_ftype_double,
+ BUILT_IN_COS, "cos");
+ builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
+ BUILT_IN_COS, "cosl");
+#if BUILT_FOR_270
+ pedantic_lvalues = FALSE;
#endif
-/* Wrapper for get_identifier. pattern is like "...%s...", text is
- inserted into final name in place of "%s", or if text is NULL,
- pattern is like "...%d..." and text form of number is inserted
- in place of "%d". */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_get_invented_identifier (const char *pattern, const char *text, int number)
-{
- tree decl;
- char *nam;
- mallocSize lenlen;
- char space[66];
-
- if (text == NULL)
- lenlen = strlen (pattern) + 20;
- else
- lenlen = strlen (pattern) + strlen (text) - 1;
- if (lenlen > ARRAY_SIZE (space))
- nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
- else
- nam = &space[0];
- if (text == NULL)
- sprintf (&nam[0], pattern, number);
- else
- sprintf (&nam[0], pattern, text);
- decl = get_identifier (nam);
- if (lenlen > ARRAY_SIZE (space))
- malloc_kill_ks (malloc_pool_image (), nam, lenlen);
-
- IDENTIFIER_INVENTED (decl) = 1;
- return decl;
-}
-
-ffeinfoBasictype
-ffecom_gfrt_basictype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
-
- switch (ffecom_gfrt_type_[gfrt])
- {
- case FFECOM_rttypeVOID_:
- case FFECOM_rttypeVOIDSTAR_:
- return FFEINFO_basictypeNONE;
+ 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");
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_basictypeINTEGER;
+ ffecom_f2c_ftnlen_zero_node
+ = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_basictypeINTEGER;
+ ffecom_f2c_ftnlen_one_node
+ = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_basictypeINTEGER;
+ ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
+ TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_basictypeLOGICAL;
+ ffecom_f2c_ptr_to_ftnlen_type_node
+ = build_pointer_type (ffecom_f2c_ftnlen_type_node);
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_basictypeREAL;
+ ffecom_f2c_ptr_to_ftnint_type_node
+ = build_pointer_type (ffecom_f2c_ftnint_type_node);
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
+ ffecom_f2c_ptr_to_integer_type_node
+ = build_pointer_type (ffecom_f2c_integer_type_node);
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_basictypeREAL;
+ ffecom_f2c_ptr_to_real_type_node
+ = build_pointer_type (ffecom_f2c_real_type_node);
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
+ ffecom_float_zero_ = build_real (float_type_node, dconst0);
+ ffecom_double_zero_ = build_real (double_type_node, dconst0);
+ {
+ REAL_VALUE_TYPE point_5;
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_basictypeCHARACTER;
+#ifdef REAL_ARITHMETIC
+ REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
+#else
+ point_5 = .5;
+#endif
+ ffecom_float_half_ = build_real (float_type_node, point_5);
+ ffecom_double_half_ = build_real (double_type_node, point_5);
+ }
- default:
- return FFEINFO_basictypeANY;
- }
-}
+ /* Do "extern int xargc;". */
-ffeinfoKindtype
-ffecom_gfrt_kindtype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
+ 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);
- switch (ffecom_gfrt_type_[gfrt])
+#if 0 /* This is being fixed, and seems to be working now. */
+ if ((FLOAT_TYPE_SIZE != 32)
+ || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
{
- case FFECOM_rttypeVOID_:
- case FFECOM_rttypeVOIDSTAR_:
- return FFEINFO_kindtypeNONE;
-
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_kindtypeINTEGER1;
+ warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
+ (int) FLOAT_TYPE_SIZE);
+ warning ("and pointers are %d bits wide, but g77 doesn't yet work",
+ (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
+ warning ("properly unless they all are 32 bits wide.");
+ warning ("Please keep this in mind before you report bugs. g77 should");
+ warning ("support non-32-bit machines better as of version 0.6.");
+ }
+#endif
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_kindtypeINTEGER1;
+#if 0 /* Code in ste.c that would crash has been commented out. */
+ if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
+ < TYPE_PRECISION (string_type_node))
+ /* I/O will probably crash. */
+ warning ("configuration: char * holds %d bits, but ftnlen only %d",
+ TYPE_PRECISION (string_type_node),
+ TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
+#endif
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_kindtypeINTEGER4;
+#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
+ if (TYPE_PRECISION (ffecom_integer_type_node)
+ < TYPE_PRECISION (string_type_node))
+ /* ASSIGN 10 TO I will crash. */
+ warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
+ ASSIGN statement might fail",
+ TYPE_PRECISION (string_type_node),
+ TYPE_PRECISION (ffecom_integer_type_node));
+#endif
+}
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_kindtypeLOGICAL1;
+#endif
+/* ffecom_init_2 -- Initialize
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_kindtypeREAL1;
+ ffecom_init_2(); */
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_kindtypeREAL1;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_init_2 ()
+{
+ assert (ffecom_outer_function_decl_ == NULL_TREE);
+ assert (current_function_decl == NULL_TREE);
+ assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_kindtypeREAL2;
+ 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;
+}
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_kindtypeREAL2;
+#endif
+/* ffecom_list_expr -- Transform list of exprs into gcc tree
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_kindtypeCHARACTER1;
+ tree t;
+ ffebld expr; // FFE opITEM list.
+ tree = ffecom_list_expr(expr);
- default:
- return FFEINFO_kindtypeANY;
- }
-}
+ List of actual args is transformed into corresponding gcc backend list. */
-void
-ffecom_init_0 ()
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_list_expr (ffebld expr)
{
- tree endlink;
- int i;
- int j;
- tree t;
- tree field;
- ffetype type;
- ffetype base_type;
-
- /* This block of code comes from the now-obsolete cktyps.c. It checks
- whether the compiler environment is buggy in known ways, some of which
- would, if not explicitly checked here, result in subtle bugs in g77. */
+ tree list;
+ tree *plist = &list;
+ tree trail = NULL_TREE; /* Append char length args here. */
+ tree *ptrail = &trail;
+ tree length;
- if (ffe_is_do_internal_checks ())
+ while (expr != NULL)
{
- static char names[][12]
- =
- {"bar", "bletch", "foo", "foobar"};
- char *name;
- unsigned long ul;
- double fl;
-
- name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
- (int (*)()) strcmp);
- if (name != (char *) &names[2])
- {
- assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
- == NULL);
- abort ();
- }
+ tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
- ul = strtoul ("123456789", NULL, 10);
- if (ul != 123456789L)
- {
- assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
- in proj.h" == NULL);
- abort ();
- }
+ if (texpr == error_mark_node)
+ return error_mark_node;
- fl = atof ("56.789");
- if ((fl < 56.788) || (fl > 56.79))
+ *plist = build_tree_list (NULL_TREE, texpr);
+ plist = &TREE_CHAIN (*plist);
+ expr = ffebld_trail (expr);
+ if (length != NULL_TREE)
{
- assert ("atof not type double, fix your #include <stdio.h>"
- == NULL);
- abort ();
+ *ptrail = build_tree_list (NULL_TREE, length);
+ ptrail = &TREE_CHAIN (*ptrail);
}
}
- /* Set the sizetype before we do anything else. This _should_ be the
- first type we create. */
-
- t = make_unsigned_type (POINTER_SIZE);
- assert (t == sizetype);
-
-#if FFECOM_GCC_INCLUDE
- ffecom_initialize_char_syntax_ ();
-#endif
-
- ffecom_outer_function_decl_ = NULL_TREE;
- current_function_decl = NULL_TREE;
- named_labels = NULL_TREE;
- current_binding_level = NULL_BINDING_LEVEL;
- free_binding_level = NULL_BINDING_LEVEL;
- pushlevel (0); /* make the binding_level structure for
- global names */
- global_binding_level = current_binding_level;
-
- /* Define `int' and `char' first so that dbx will output them first. */
-
- integer_type_node = make_signed_type (INT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
- integer_type_node));
-
- char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
- char_type_node));
-
- long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
- long_integer_type_node));
-
- unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
- unsigned_type_node));
+ *plist = trail;
- long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
- long_unsigned_type_node));
+ return list;
+}
- long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
- long_long_integer_type_node));
+#endif
+/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
- long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
- long_long_unsigned_type_node));
+ tree t;
+ ffebld expr; // FFE opITEM list.
+ tree = ffecom_list_ptr_to_expr(expr);
- error_mark_node = make_node (ERROR_MARK);
- TREE_TYPE (error_mark_node) = error_mark_node;
+ List of actual args is transformed into corresponding gcc backend list for
+ use in calling an external procedure (vs. a statement function). */
- short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
- short_integer_type_node));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_list_ptr_to_expr (ffebld expr)
+{
+ tree list;
+ tree *plist = &list;
+ tree trail = NULL_TREE; /* Append char length args here. */
+ tree *ptrail = &trail;
+ tree length;
- short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
- short_unsigned_type_node));
+ while (expr != NULL)
+ {
+ tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
- /* Define both `signed char' and `unsigned char'. */
- signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
- signed_char_type_node));
+ if (texpr == error_mark_node)
+ return error_mark_node;
- unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
- unsigned_char_type_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);
+ }
+ }
- float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
- layout_type (float_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
- float_type_node));
+ *plist = trail;
- double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
- layout_type (double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
- double_type_node));
+ return list;
+}
- long_double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (long_double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
- long_double_type_node));
+#endif
+/* Obtain gcc's LABEL_DECL tree for label. */
- complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
- complex_integer_type_node));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_lookup_label (ffelab label)
+{
+ tree glabel;
- complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
- complex_float_type_node));
+ if (ffelab_hook (label) == NULL_TREE)
+ {
+ char labelname[16];
- complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
- complex_double_type_node));
+ 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;
- complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
- complex_long_double_type_node));
+ case FFELAB_typeFORMAT:
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
- integer_zero_node = build_int_2 (0, 0);
- TREE_TYPE (integer_zero_node) = integer_type_node;
- integer_one_node = build_int_2 (1, 0);
- TREE_TYPE (integer_one_node) = integer_type_node;
+ glabel = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier
+ ("__g77_format_%d", NULL,
+ (int) ffelab_value (label)),
+ build_type_variant (build_array_type
+ (char_type_node,
+ NULL_TREE),
+ 1, 0));
+ TREE_CONSTANT (glabel) = 1;
+ TREE_STATIC (glabel) = 1;
+ DECL_CONTEXT (glabel) = 0;
+ DECL_INITIAL (glabel) = NULL;
+ make_decl_rtl (glabel, NULL, 0);
+ expand_decl (glabel);
- size_zero_node = build_int_2 (0, 0);
- TREE_TYPE (size_zero_node) = sizetype;
- size_one_node = build_int_2 (1, 0);
- TREE_TYPE (size_one_node) = sizetype;
+ resume_temporary_allocation ();
+ pop_obstacks ();
- void_type_node = make_node (VOID_TYPE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
- void_type_node));
- layout_type (void_type_node); /* Uses integer_zero_node */
- /* We are not going to have real types in C with less than byte alignment,
- so we might as well not have any types that claim to have it. */
- TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
+ break;
- null_pointer_node = build_int_2 (0, 0);
- TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
- layout_type (TREE_TYPE (null_pointer_node));
+ case FFELAB_typeANY:
+ glabel = error_mark_node;
+ break;
- string_type_node = build_pointer_type (char_type_node);
+ default:
+ assert ("bad label type" == NULL);
+ glabel = NULL;
+ break;
+ }
+ ffelab_set_hook (label, glabel);
+ }
+ else
+ {
+ glabel = ffelab_hook (label);
+ }
- ffecom_tree_fun_type_void
- = build_function_type (void_type_node, NULL_TREE);
+ return glabel;
+}
- ffecom_tree_ptr_to_fun_type_void
- = build_pointer_type (ffecom_tree_fun_type_void);
+#endif
+/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
+ a single source specification (as in the fourth argument of MVBITS).
+ If the type is NULL_TREE, the type of lhs is used to make the type of
+ the MODIFY_EXPR. */
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_modify (tree newtype, tree lhs,
+ tree rhs)
+{
+ if (lhs == error_mark_node || rhs == error_mark_node)
+ return error_mark_node;
- float_ftype_float
- = build_function_type (float_type_node,
- tree_cons (NULL_TREE, float_type_node, endlink));
+ if (newtype == NULL_TREE)
+ newtype = TREE_TYPE (lhs);
- double_ftype_double
- = build_function_type (double_type_node,
- tree_cons (NULL_TREE, double_type_node, endlink));
+ if (TREE_SIDE_EFFECTS (lhs))
+ lhs = stabilize_reference (lhs);
- ldouble_ftype_ldouble
- = build_function_type (long_double_type_node,
- tree_cons (NULL_TREE, long_double_type_node,
- endlink));
+ return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
+}
- 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;
- }
+#endif
- /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
- to size FLOAT_TYPE_SIZE because they have to be the same size as
- REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
- Compiler options and other such stuff that change the ways these
- types are set should not affect this particular setup. */
+/* Register source file name. */
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
- = t = make_signed_type (FLOAT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger1));
+void
+ffecom_file (char *name)
+{
+#if FFECOM_GCC_INCLUDE
+ ffecom_file_ (name);
+#endif
+}
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
- t));
+/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
- 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));
+ ffestorag st;
+ ffecom_notify_init_storage(st);
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
- = t = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
- t));
+ Gets called when all possible units in an aggregate storage area (a LOCAL
+ with equivalences or a COMMON) have been initialized. The initialization
+ info either is in ffestorag_init or, if that is NULL,
+ ffestorag_accretion:
- 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));
+ ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
+ even for an array if the array is one element in length!
- 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));
+ ffestorag_accretion will contain an opACCTER. It is much like an
+ opARRTER except it has an ffebit object in it instead of just a size.
+ The back end can use the info in the ffebit object, if it wants, to
+ reduce the amount of actual initialization, but in any case it should
+ kill the ffebit object when done. Also, set accretion to NULL but
+ init to a non-NULL value.
- 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));
+ After performing initialization, DO NOT set init to NULL, because that'll
+ tell the front end it is ok for more initialization to happen. Instead,
+ set init to an opANY expression or some such thing that you can use to
+ tell that you've already initialized the object.
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
- t));
+ 27-Oct-91 JCB 1.1
+ Support two-pass FFE. */
-#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)
+void
+ffecom_notify_init_storage (ffestorag st)
+{
+ ffebld init; /* The initialization expression. */
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffetargetOffset size; /* The size of the entity. */
+ ffetargetAlign pad; /* Its initial padding. */
+#endif
+
+ if (ffestorag_init (st) == NULL)
{
- fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
- LONG_TYPE_SIZE);
+ init = ffestorag_accretion (st);
+ assert (init != NULL);
+ ffestorag_set_accretion (st, NULL);
+ ffestorag_set_accretes (st, 0);
+
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
+ size = ffebld_accter_size (init);
+ pad = ffebld_accter_pad (init);
+ ffebit_kill (ffebld_accter_bits (init));
+ ffebld_set_op (init, FFEBLD_opARRTER);
+ ffebld_set_arrter (init, ffebld_accter (init));
+ ffebld_arrter_set_size (init, size);
+ ffebld_arrter_set_pad (init, size);
+#endif
+
+#if FFECOM_TWOPASS
+ ffestorag_set_init (st, init);
+#endif
}
+#if FFECOM_ONEPASS
+ else
+ init = ffestorag_init (st);
#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));
+#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
+ ffestorag_set_init (st, ffebld_new_any ());
- 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));
+ if (ffebld_op (init) == FFEBLD_opANY)
+ return; /* Oh, we already did this! */
- 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));
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ {
+ ffesymbol s;
- 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));
+ if (ffestorag_symbol (st) != NULL)
+ s = ffestorag_symbol (st);
+ else
+ s = ffestorag_typesymbol (st);
- 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));
+ fprintf (dmpout, "= initialize_storage \"%s\" ",
+ (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
+ ffebld_dump (init);
+ fputc ('\n', dmpout);
+ }
+#endif
- ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
- = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
- t));
- layout_type (t);
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
- = FFETARGET_f2cTYDREAL;
- assert (ffetype_size (type) == sizeof (ffetargetReal2));
+#endif /* if FFECOM_ONEPASS */
+}
- 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_notify_init_symbol -- A symbol is now fully init'ed
- 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));
+ ffesymbol s;
+ ffecom_notify_init_symbol(s);
- /* Make function and ptr-to-function types for non-CHARACTER types. */
+ Gets called when all possible units in a symbol (not placed in COMMON
+ or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
+ have been initialized. The initialization info either is in
+ ffesymbol_init or, if that is NULL, ffesymbol_accretion:
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
- {
- if (i == FFEINFO_basictypeINTEGER)
- {
- /* Figure out the smallest INTEGER type that can hold
- a pointer on this machine. */
- if (GET_MODE_SIZE (TYPE_MODE (t))
- >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
- {
- if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
- || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
- > GET_MODE_SIZE (TYPE_MODE (t))))
- ffecom_pointer_kind_ = j;
- }
- }
- else if (i == FFEINFO_basictypeCOMPLEX)
- t = void_type_node;
- /* For f2c compatibility, REAL functions are really
- implemented as DOUBLE PRECISION. */
- else if ((i == FFEINFO_basictypeREAL)
- && (j == FFEINFO_kindtypeREAL1))
- t = ffecom_tree_type
- [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
+ ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
+ even for an array if the array is one element in length!
- 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);
- }
- }
+ ffesymbol_accretion will contain an opACCTER. It is much like an
+ opARRTER except it has an ffebit object in it instead of just a size.
+ The back end can use the info in the ffebit object, if it wants, to
+ reduce the amount of actual initialization, but in any case it should
+ kill the ffebit object when done. Also, set accretion to NULL but
+ init to a non-NULL value.
- /* Set up pointer types. */
+ After performing initialization, DO NOT set init to NULL, because that'll
+ tell the front end it is ok for more initialization to happen. Instead,
+ set init to an opANY expression or some such thing that you can use to
+ tell that you've already initialized the object.
- if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
- fatal ("no INTEGER type can hold a pointer on this configuration");
- else if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
- ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT),
- 7,
- ffeinfo_type (FFEINFO_basictypeINTEGER,
- ffecom_pointer_kind_));
+ 27-Oct-91 JCB 1.1
+ Support two-pass FFE. */
- if (ffe_is_ugly_assign ())
- ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
- else
- ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
- if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
+void
+ffecom_notify_init_symbol (ffesymbol s)
+{
+ ffebld init; /* The initialization expression. */
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffetargetOffset size; /* The size of the entity. */
+ ffetargetAlign pad; /* Its initial padding. */
+#endif
- 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);
+ if (ffesymbol_storage (s) == NULL)
+ return; /* Do nothing until COMMON/EQUIVALENCE
+ possibilities checked. */
- /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
- Turns out that by TYLONG, runtime/libI77/lio.h really means
- "whatever size an ftnint is". For consistency and sanity,
- com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
- all are INTEGER, which we also make out of whatever back-end
- integer type is FLOAT_TYPE_SIZE bits wide. This change, from
- LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
- accommodate machines like the Alpha. Note that this suggests
- f2c and libf2c are missing a distinction perhaps needed on
- some machines between "int" and "long int". -- burley 0.5.5 950215 */
+ if ((ffesymbol_init (s) == NULL)
+ && ((init = ffesymbol_accretion (s)) != NULL))
+ {
+ ffesymbol_set_accretion (s, NULL);
+ ffesymbol_set_accretes (s, 0);
- 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 /* ~~~ */);
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
+ size = ffebld_accter_size (init);
+ pad = ffebld_accter_pad (init);
+ ffebit_kill (ffebld_accter_bits (init));
+ ffebld_set_op (init, FFEBLD_opARRTER);
+ ffebld_set_arrter (init, ffebld_accter (init));
+ ffebld_arrter_set_size (init, size);
+ ffebld_arrter_set_pad (init, size);
+#endif
- /* CHARACTER stuff is all special-cased, so it is not handled in the above
- loop. CHARACTER items are built as arrays of unsigned char. */
+#if FFECOM_TWOPASS
+ ffesymbol_set_init (s, init);
+#endif
+ }
+#if FFECOM_ONEPASS
+ else
+ init = ffesymbol_init (s);
+#endif
- 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]));
+#if FFECOM_ONEPASS
+ ffesymbol_set_init (s, ffebld_new_any ());
- 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;
+ if (ffebld_op (init) == FFEBLD_opANY)
+ return; /* Oh, we already did this! */
- ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
- = 0;
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
+ ffebld_dump (init);
+ fputc ('\n', dmpout);
+#endif
- /* Make multi-return-value type and fields. */
+#endif /* if FFECOM_ONEPASS */
+}
- ffecom_multi_type_node_ = make_node (UNION_TYPE);
+/* ffecom_notify_primary_entry -- Learn which is the primary entry point
- field = NULL_TREE;
+ ffesymbol s;
+ ffecom_notify_primary_entry(s);
- 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];
+ Gets called when implicit or explicit PROGRAM statement seen or when
+ FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
+ global symbol that serves as the entry point. */
- if (ffecom_tree_type[i][j] == NULL_TREE)
- continue; /* Not supported. */
- sprintf (&name[0], "bt_%s_kt_%s",
- ffeinfo_basictype_string ((ffeinfoBasictype) i),
- ffeinfo_kindtype_string ((ffeinfoKindtype) j));
- ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
- get_identifier (name),
- ffecom_tree_type[i][j]);
- DECL_CONTEXT (ffecom_multi_fields_[i][j])
- = ffecom_multi_type_node_;
- DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
- TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
- field = ffecom_multi_fields_[i][j];
- }
+void
+ffecom_notify_primary_entry (ffesymbol s)
+{
+ ffecom_primary_entry_ = s;
+ ffecom_primary_entry_kind_ = ffesymbol_kind (s);
- TYPE_FIELDS (ffecom_multi_type_node_) = field;
- layout_type (ffecom_multi_type_node_);
+ 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;
- /* Subroutines usually return integer because they might have alternate
- returns. */
+ 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));
+ }
- 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);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
+ {
+ ffebld list;
+ ffebld arg;
- builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_FSQRT, "sqrtf");
- builtin_function ("__builtin_fsqrt", double_ftype_double,
- BUILT_IN_FSQRT, "sqrt");
- builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_FSQRT, "sqrtl");
- builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SIN, "sinf");
- builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, "sin");
- builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SIN, "sinl");
- builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COS, "cosf");
- builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, "cos");
- builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COS, "cosl");
+ for (list = ffesymbol_dummyargs (s);
+ list != NULL;
+ list = ffebld_trail (list))
+ {
+ arg = ffebld_head (list);
+ if (ffebld_op (arg) == FFEBLD_opSTAR)
+ {
+ ffecom_is_altreturning_ = TRUE;
+ break;
+ }
+ }
+ }
+#endif
+}
-#if BUILT_FOR_270
- pedantic_lvalues = FALSE;
+FILE *
+ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
+{
+#if FFECOM_GCC_INCLUDE
+ return ffecom_open_include_ (name, l, c);
+#else
+ return fopen (name, "r");
#endif
+}
- 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_ptr_to_expr -- Transform expr into gcc tree with & in front
- ffecom_f2c_ftnlen_zero_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
+ tree t;
+ ffebld expr; // FFE expression.
+ tree = ffecom_ptr_to_expr(expr);
- ffecom_f2c_ftnlen_one_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
+ Like ffecom_expr, but sticks address-of in front of most things. */
- ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
- TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_ptr_to_expr (ffebld expr)
+{
+ tree item;
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffesymbol s;
- ffecom_f2c_ptr_to_ftnlen_type_node
- = build_pointer_type (ffecom_f2c_ftnlen_type_node);
+ assert (expr != NULL);
- ffecom_f2c_ptr_to_ftnint_type_node
- = build_pointer_type (ffecom_f2c_ftnint_type_node);
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opSYMTER:
+ s = ffebld_symter (expr);
+ if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
+ {
+ ffecomGfrt ix;
- ffecom_f2c_ptr_to_integer_type_node
- = build_pointer_type (ffecom_f2c_integer_type_node);
+ 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;
- ffecom_f2c_ptr_to_real_type_node
- = build_pointer_type (ffecom_f2c_real_type_node);
+ case FFEBLD_opARRAYREF:
+ {
+ ffebld dims[FFECOM_dimensionsMAX];
+ tree array;
+ int i;
- ffecom_float_zero_ = build_real (float_type_node, dconst0);
- ffecom_double_zero_ = build_real (double_type_node, dconst0);
- {
- REAL_VALUE_TYPE point_5;
+ item = ffecom_ptr_to_expr (ffebld_left (expr));
-#ifdef REAL_ARITHMETIC
- REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
-#else
- point_5 = .5;
-#endif
- ffecom_float_half_ = build_real (float_type_node, point_5);
- ffecom_double_half_ = build_real (double_type_node, point_5);
- }
+ if (item == error_mark_node)
+ return item;
- /* Do "extern int xargc;". */
+ if ((ffebld_where (expr) == FFEINFO_whereFLEETING)
+ && !mark_addressable (item))
+ return error_mark_node; /* Make sure non-const ref is to
+ non-reg. */
- 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);
+ /* Build up ARRAY_REFs in reverse order (since we're column major
+ here in Fortran land). */
-#if 0 /* This is being fixed, and seems to be working now. */
- if ((FLOAT_TYPE_SIZE != 32)
- || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
- {
- warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
- (int) FLOAT_TYPE_SIZE);
- warning ("and pointers are %d bits wide, but g77 doesn't yet work",
- (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
- warning ("properly unless they all are 32 bits wide.");
- warning ("Please keep this in mind before you report bugs. g77 should");
- warning ("support non-32-bit machines better as of version 0.6.");
- }
-#endif
+ for (i = 0, expr = ffebld_right (expr);
+ expr != NULL;
+ expr = ffebld_trail (expr))
+ dims[i++] = ffebld_head (expr);
-#if 0 /* Code in ste.c that would crash has been commented out. */
- if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
- < TYPE_PRECISION (string_type_node))
- /* I/O will probably crash. */
- warning ("configuration: char * holds %d bits, but ftnlen only %d",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
-#endif
+ for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
+ i >= 0;
+ --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
+ {
+ /* The initial subtraction should happen in the original type so
+ that (possible) negative values are handled appropriately. */
+ 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 (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
+ ffecom_expr (dims[i]),
+ TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
+ }
+ }
+ return item;
-#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
- if (TYPE_PRECISION (ffecom_integer_type_node)
- < TYPE_PRECISION (string_type_node))
- /* ASSIGN 10 TO I will crash. */
- warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
- ASSIGN statement might fail",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_integer_type_node));
-#endif
-}
+ case FFEBLD_opCONTER:
-#endif
-/* ffecom_init_2 -- Initialize
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
- ffecom_init_2(); */
+ 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;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_init_2 ()
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
- assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
+ case FFEBLD_opANY:
+ return error_mark_node;
- ffecom_master_arglist_ = NULL;
- ++ffecom_num_fns_;
- ffecom_latest_temp_ = NULL;
- ffecom_primary_entry_ = NULL;
- ffecom_is_altreturning_ = FALSE;
- ffecom_func_result_ = NULL_TREE;
- ffecom_multi_retval_ = NULL_TREE;
+ default:
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+
+ item = ffecom_expr (expr);
+ if (item == error_mark_node)
+ return error_mark_node;
+
+ /* The back end currently optimizes a bit too zealously for us, in that
+ we fail JCB001 if the following block of code is omitted. It checks
+ to see if the transformed expression is a symbol or array reference,
+ and encloses it in a SAVE_EXPR if that is the case. */
+
+ STRIP_NOPS (item);
+ if ((TREE_CODE (item) == VAR_DECL)
+ || (TREE_CODE (item) == PARM_DECL)
+ || (TREE_CODE (item) == RESULT_DECL)
+ || (TREE_CODE (item) == INDIRECT_REF)
+ || (TREE_CODE (item) == ARRAY_REF)
+ || (TREE_CODE (item) == COMPONENT_REF)
+#ifdef OFFSET_REF
+ || (TREE_CODE (item) == OFFSET_REF)
+#endif
+ || (TREE_CODE (item) == BUFFER_REF)
+ || (TREE_CODE (item) == REALPART_EXPR)
+ || (TREE_CODE (item) == IMAGPART_EXPR))
+ {
+ item = ffecom_save_tree (item);
+ }
+
+ item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
+ item);
+ return item;
+ }
+
+ assert ("fall-through error" == NULL);
+ return error_mark_node;
}
#endif
-/* ffecom_list_expr -- Transform list of exprs into gcc tree
+/* Obtain a temp var with given data type.
- tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_expr(expr);
+ size is FFETARGET_charactersizeNONE for a non-CHARACTER type
+ or >= 0 for a CHARACTER type.
- List of actual args is transformed into corresponding gcc backend list. */
+ elements is -1 for a scalar or > 0 for an array of type. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_list_expr (ffebld expr)
+ffecom_make_tempvar (const char *commentary, tree type,
+ ffetargetCharacterSize size, int elements)
{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
+ int yes;
+ tree t;
+ static int mynumber;
- while (expr != NULL)
- {
- tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
+ assert (current_binding_level->prep_state < 2);
- if (texpr == error_mark_node)
- return error_mark_node;
+ if (type == 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);
- }
- }
+ yes = suspend_momentary ();
- *plist = trail;
+ 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);
- return list;
-}
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
+
+ resume_momentary (yes);
+ return t;
+}
#endif
-/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
- tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_ptr_to_expr(expr);
+/* Prepare argument pointer to expression.
- List of actual args is transformed into corresponding gcc backend list for
- use in calling an external procedure (vs. a statement function). */
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_arg_ptr_to_expr. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_list_ptr_to_expr (ffebld expr)
+void
+ffecom_prepare_arg_ptr_to_expr (ffebld expr)
{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
-
- while (expr != NULL)
- {
- tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
- if (texpr == error_mark_node)
- return error_mark_node;
+/* End of preparations. */
- *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);
- }
- }
+bool
+ffecom_prepare_end (void)
+{
+ int prep_state = current_binding_level->prep_state;
- *plist = trail;
+ assert (prep_state < 2);
+ current_binding_level->prep_state = 2;
- return list;
+ return (prep_state == 1) ? TRUE : FALSE;
}
-#endif
-/* Obtain gcc's LABEL_DECL tree for label. */
+/* Prepare expression.
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_lookup_label (ffelab label)
+ This is called before any code is generated for the current block.
+ It scans the expression, declares any temporaries that might be needed
+ during evaluation of the expression, and stores those temporaries in
+ the appropriate "hook" fields of the expression. `dest', if not NULL,
+ specifies the destination that ffecom_expr_ will see, in case that
+ helps avoid generating unused temporaries.
+
+ ~~Improve to avoid allocating unused temporaries by taking `dest'
+ into account vis-a-vis aliasing requirements of complex/character
+ functions. */
+
+void
+ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
{
- tree glabel;
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffetargetCharacterSize sz;
+ tree tempvar = NULL_TREE;
- if (ffelab_hook (label) == NULL_TREE)
+ assert (current_binding_level->prep_state < 2);
+
+ if (! expr)
+ return;
+
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ sz = ffeinfo_size (ffebld_info (expr));
+
+ /* Generate whatever temporaries are needed to represent the result
+ of the expression. */
+
+ switch (ffebld_op (expr))
{
- char labelname[16];
+ default:
+ /* Don't make temps for SYMTER, CONTER, etc. */
+ if (ffebld_arity (expr) == 0)
+ break;
- switch (ffelab_type (label))
+ switch (bt)
{
- case FFELAB_typeLOOPEND:
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeENDIF:
- sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
- glabel = build_decl (LABEL_DECL, get_identifier (labelname),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
- break;
-
- case FFELAB_typeFORMAT:
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ case FFEINFO_basictypeCOMPLEX:
+ if (ffebld_op (expr) == FFEBLD_opFUNCREF)
+ {
+ ffesymbol s;
- glabel = build_decl (VAR_DECL,
- ffecom_get_invented_identifier
- ("__g77_format_%d", NULL,
- (int) ffelab_value (label)),
- build_type_variant (build_array_type
- (char_type_node,
- NULL_TREE),
- 1, 0));
- TREE_CONSTANT (glabel) = 1;
- TREE_STATIC (glabel) = 1;
- DECL_CONTEXT (glabel) = 0;
- DECL_INITIAL (glabel) = NULL;
- make_decl_rtl (glabel, NULL, 0);
- expand_decl (glabel);
+ if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
+ break;
- resume_temporary_allocation ();
- pop_obstacks ();
+ s = ffebld_symter (ffebld_left (expr));
+ if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
+ || ! ffesymbol_is_f2c (s))
+ break;
+ }
+ else if (ffebld_op (expr) == FFEBLD_opPOWER)
+ {
+ /* Requires special treatment. There's no POW_CC function
+ in libg2c, so POW_ZZ is used, which means we always
+ need a double-complex temp, not a single-complex. */
+ kt = FFEINFO_kindtypeREAL2;
+ }
+ else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
+ /* The other ops don't need temps for complex operands. */
+ break;
+ /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
+ REAL(C). See 19990325-0.f, routine `check', for cases. */
+ tempvar = ffecom_make_tempvar ("complex",
+ ffecom_tree_type
+ [FFEINFO_basictypeCOMPLEX][kt],
+ FFETARGET_charactersizeNONE,
+ -1);
break;
- case FFELAB_typeANY:
- glabel = error_mark_node;
+ case FFEINFO_basictypeCHARACTER:
+ if (ffebld_op (expr) != FFEBLD_opFUNCREF)
+ break;
+
+ if (sz == FFETARGET_charactersizeNONE)
+ /* ~~Kludge alert! This should someday be fixed. */
+ sz = 24;
+
+ tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
break;
default:
- assert ("bad label type" == NULL);
- glabel = NULL;
break;
}
- ffelab_set_hook (label, glabel);
- }
- else
- {
- glabel = ffelab_hook (label);
- }
-
- return glabel;
-}
-
-#endif
-/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
- a single source specification (as in the fourth argument of MVBITS).
- If the type is NULL_TREE, the type of lhs is used to make the type of
- the MODIFY_EXPR. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_modify (tree newtype, tree lhs,
- tree rhs)
-{
- if (lhs == error_mark_node || rhs == error_mark_node)
- return error_mark_node;
+ break;
- if (newtype == NULL_TREE)
- newtype = TREE_TYPE (lhs);
+#ifdef HAHA
+ case FFEBLD_opPOWER:
+ {
+ tree rtype, ltype;
+ tree rtmp, ltmp, result;
- if (TREE_SIDE_EFFECTS (lhs))
- lhs = stabilize_reference (lhs);
+ ltype = ffecom_type_expr (ffebld_left (expr));
+ rtype = ffecom_type_expr (ffebld_right (expr));
- return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
-}
+ rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
+ ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
+ result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
-#endif
+ tempvar = make_tree_vec (3);
+ TREE_VEC_ELT (tempvar, 0) = rtmp;
+ TREE_VEC_ELT (tempvar, 1) = ltmp;
+ TREE_VEC_ELT (tempvar, 2) = result;
+ }
+ break;
+#endif /* HAHA */
-/* Register source file name. */
+ case FFEBLD_opCONCATENATE:
+ {
+ /* This gets special handling, because only one set of temps
+ is needed for a tree of these -- the tree is treated as
+ a flattened list of concatenations when generating code. */
-void
-ffecom_file (char *name)
-{
-#if FFECOM_GCC_INCLUDE
- ffecom_file_ (name);
-#endif
-}
+ ffecomConcatList_ catlist;
+ tree ltmp, itmp, result;
+ int count;
+ int i;
-/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
+ catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
+ count = ffecom_concat_list_count_ (catlist);
- ffestorag st;
- ffecom_notify_init_storage(st);
+ 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;
+ }
- Gets called when all possible units in an aggregate storage area (a LOCAL
- with equivalences or a COMMON) have been initialized. The initialization
- info either is in ffestorag_init or, if that is NULL,
- ffestorag_accretion:
+ for (i = 0; i < count; ++i)
+ ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
+ i));
- ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
+ ffecom_concat_list_kill_ (catlist);
- ffestorag_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (expr, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+ }
+ return;
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
+ 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;
+ }
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (expr, tempvar);
+ current_binding_level->prep_state = 1;
+ }
-void
-ffecom_notify_init_storage (ffestorag st)
-{
- ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
- ffetargetAlign pad; /* Its initial padding. */
-#endif
+ /* Prepare subexpressions for this expr. */
- if (ffestorag_init (st) == NULL)
+ switch (ffebld_op (expr))
{
- init = ffestorag_accretion (st);
- assert (init != NULL);
- ffestorag_set_accretion (st, NULL);
- ffestorag_set_accretes (st, 0);
+ case FFEBLD_opPERCENT_LOC:
+ ffecom_prepare_ptr_to_expr (ffebld_left (expr));
+ break;
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- pad = ffebld_accter_pad (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
- ffebld_arrter_set_pad (init, size);
-#endif
+ case FFEBLD_opPERCENT_VAL:
+ case FFEBLD_opPERCENT_REF:
+ ffecom_prepare_expr (ffebld_left (expr));
+ break;
-#if FFECOM_TWOPASS
- ffestorag_set_init (st, init);
-#endif
- }
-#if FFECOM_ONEPASS
- else
- init = ffestorag_init (st);
-#endif
+ case FFEBLD_opPERCENT_DESCR:
+ ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
+ break;
-#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
- ffestorag_set_init (st, ffebld_new_any ());
+ case FFEBLD_opITEM:
+ {
+ ffebld item;
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
+ for (item = expr;
+ item != NULL;
+ item = ffebld_trail (item))
+ if (ffebld_head (item) != NULL)
+ ffecom_prepare_expr (ffebld_head (item));
+ }
+ break;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- {
- ffesymbol s;
+ default:
+ /* Need to handle character conversion specially. */
+ switch (ffebld_arity (expr))
+ {
+ case 2:
+ ffecom_prepare_expr (ffebld_left (expr));
+ ffecom_prepare_expr (ffebld_right (expr));
+ break;
- if (ffestorag_symbol (st) != NULL)
- s = ffestorag_symbol (st);
- else
- s = ffestorag_typesymbol (st);
+ case 1:
+ ffecom_prepare_expr (ffebld_left (expr));
+ break;
- fprintf (dmpout, "= initialize_storage \"%s\" ",
- (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
- ffebld_dump (init);
- fputc ('\n', dmpout);
- }
-#endif
+ default:
+ break;
+ }
+ }
-#endif /* if FFECOM_ONEPASS */
+ return;
}
-/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
-
- ffesymbol s;
- ffecom_notify_init_symbol(s);
+/* Prepare expression for reading and writing.
- Gets called when all possible units in a symbol (not placed in COMMON
- or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
- have been initialized. The initialization info either is in
- ffesymbol_init or, if that is NULL, ffesymbol_accretion:
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_expr_rw. */
- ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
+void
+ffecom_prepare_expr_rw (tree type, ffebld expr)
+{
+ /* This is all we support for now. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
- ffesymbol_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
+/* Prepare expression for writing.
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_expr_w. */
void
-ffecom_notify_init_symbol (ffesymbol s)
+ffecom_prepare_expr_w (tree type, ffebld expr)
{
- ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
- ffetargetAlign pad; /* Its initial padding. */
-#endif
+ /* This is all we support for now. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
- if (ffesymbol_storage (s) == NULL)
- return; /* Do nothing until COMMON/EQUIVALENCE
- possibilities checked. */
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
- if ((ffesymbol_init (s) == NULL)
- && ((init = ffesymbol_accretion (s)) != NULL))
- {
- ffesymbol_set_accretion (s, NULL);
- ffesymbol_set_accretes (s, 0);
+/* Prepare expression for returning.
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- pad = ffebld_accter_pad (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
- ffebld_arrter_set_pad (init, size);
-#endif
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_return_expr. */
-#if FFECOM_TWOPASS
- ffesymbol_set_init (s, init);
-#endif
- }
-#if FFECOM_ONEPASS
- else
- init = ffesymbol_init (s);
-#endif
+void
+ffecom_prepare_return_expr (ffebld expr)
+{
+ assert (current_binding_level->prep_state < 2);
-#if FFECOM_ONEPASS
- ffesymbol_set_init (s, ffebld_new_any ());
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
+ && ffecom_is_altreturning_
+ && expr != NULL)
+ ffecom_prepare_expr (expr);
+}
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
+/* Prepare pointer to expression.
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
- ffebld_dump (init);
- fputc ('\n', dmpout);
-#endif
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_ptr_to_expr. */
-#endif /* if FFECOM_ONEPASS */
+void
+ffecom_prepare_ptr_to_expr (ffebld expr)
+{
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
}
-/* ffecom_notify_primary_entry -- Learn which is the primary entry point
+/* Transform expression into constant pointer-to-expression tree.
- ffesymbol s;
- ffecom_notify_primary_entry(s);
+ If the expression can be transformed into a pointer-to-expression tree
+ that is constant, that is done, and the tree returned. Else NULL_TREE
+ is returned.
- Gets called when implicit or explicit PROGRAM statement seen or when
- FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
- global symbol that serves as the entry point. */
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
-void
-ffecom_notify_primary_entry (ffesymbol s)
+tree
+ffecom_ptr_to_const_expr (ffebld expr)
{
- ffecom_primary_entry_ = s;
- ffecom_primary_entry_kind_ = ffesymbol_kind (s);
+ if (! expr)
+ return integer_zero_node;
- 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 (ffebld_op (expr) == FFEBLD_opANY)
+ return error_mark_node;
- if (!ffe_is_silent ())
+ 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))
{
- if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
- fprintf (stderr, "%s:\n", ffesymbol_text (s));
- else
- fprintf (stderr, " %s:\n", ffesymbol_text (s));
+ tree t;
+
+ t = ffecom_ptr_to_expr (expr);
+ assert (TREE_CONSTANT (t));
+ return t;
}
+ return NULL_TREE;
+}
+
+/* ffecom_return_expr -- Returns return-value expr given alt return expr
+
+ tree rtn; // NULL_TREE means use expand_null_return()
+ ffebld expr; // NULL if no alt return expr to RETURN stmt
+ rtn = ffecom_return_expr(expr);
+
+ Based on the program unit type and other info (like return function
+ type, return master function type when alternate ENTRY points,
+ whether subroutine has any alternate RETURN points, etc), returns the
+ appropriate expression to be returned to the caller, or NULL_TREE
+ meaning no return value or the caller expects it to be returned somewhere
+ else (which is handled by other parts of this module). */
+
#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
+tree
+ffecom_return_expr (ffebld expr)
+{
+ tree rtn;
+
+ switch (ffecom_primary_entry_kind_)
{
- ffebld list;
- ffebld arg;
+ case FFEINFO_kindPROGRAM:
+ case FFEINFO_kindBLOCKDATA:
+ rtn = NULL_TREE;
+ break;
- 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;
- }
+ case FFEINFO_kindSUBROUTINE:
+ if (!ffecom_is_altreturning_)
+ rtn = NULL_TREE; /* No alt returns, never an expr. */
+ else if (expr == NULL)
+ rtn = integer_zero_node;
+ else
+ rtn = ffecom_expr (expr);
+ break;
+
+ case FFEINFO_kindFUNCTION:
+ if ((ffecom_multi_retval_ != NULL_TREE)
+ || (ffesymbol_basictype (ffecom_primary_entry_)
+ == FFEINFO_basictypeCHARACTER)
+ || ((ffesymbol_basictype (ffecom_primary_entry_)
+ == FFEINFO_basictypeCOMPLEX)
+ && (ffecom_num_entrypoints_ == 0)
+ && ffesymbol_is_f2c (ffecom_primary_entry_)))
+ { /* Value is returned by direct assignment
+ into (implicit) dummy. */
+ rtn = NULL_TREE;
+ break;
}
- }
-#endif
-}
+ rtn = ffecom_func_result_;
+#if 0
+ /* Spurious error if RETURN happens before first reference! So elide
+ this code. In particular, for debugging registry, rtn should always
+ be non-null after all, but TREE_USED won't be set until we encounter
+ a reference in the code. Perfectly okay (but weird) code that,
+ e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
+ this diagnostic for no reason. Have people use -O -Wuninitialized
+ and leave it to the back end to find obviously weird cases. */
-FILE *
-ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
-{
-#if FFECOM_GCC_INCLUDE
- return ffecom_open_include_ (name, l, c);
-#else
- return fopen (name, "r");
+ /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
+ situation; if the return value has never been referenced, it won't
+ have a tree under 2pass mode. */
+ if ((rtn == NULL_TREE)
+ || !TREE_USED (rtn))
+ {
+ ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
+ ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
+ ffesymbol_where_column (ffecom_primary_entry_));
+ ffebad_string (ffesymbol_text (ffesymbol_funcresult
+ (ffecom_primary_entry_)));
+ ffebad_finish ();
+ }
#endif
-}
-
-/* Clean up after making automatically popped call-arg temps.
+ break;
- Call this in pairs with push_calltemps around calls to
- ffecom_arg_ptr_to_expr if the latter might use temporaries.
- Any temporaries made within the outermost sequence of
- push_calltemps and pop_calltemps, that are marked as "auto-pop"
- meaning they won't be explicitly popped (freed), are popped
- at this point so they can be reused later.
+ default:
+ assert ("bad unit kind" == NULL);
+ case FFEINFO_kindANY:
+ rtn = error_mark_node;
+ break;
+ }
- NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
- should come in == 1, and all of the in-use auto-pop temps
- should have DECL_CONTEXT (temp->t) == current_function_decl.
- Moreover, these temps should _never_ be re-used in future
- calls to ffecom_push_tempvar -- since current_function_decl will
- never be the same again.
+ return rtn;
+}
- SO, it could be a minor win in terms of compile time to just
- strip these temps off the list. That is, if the above assumptions
- are correct, just remove from the list of temps any temp
- that is both in-use and has DECL_CONTEXT (temp->t)
- == current_function_decl, when called from ffecom_gen_sfuncdef_. */
+#endif
+/* Do save_expr only if tree is not error_mark_node. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_pop_calltemps ()
+tree
+ffecom_save_tree (tree t)
{
- ffecomTemp_ temp;
-
- assert (ffecom_pending_calls_ > 0);
-
- if (--ffecom_pending_calls_ == 0)
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- if (temp->auto_pop)
- temp->in_use = FALSE;
+ return save_expr (t);
}
-
#endif
-/* Mark latest temp with given tree as no longer in use. */
+
+/* Start a compound statement (block). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_pop_tempvar (tree t)
+ffecom_start_compstmt (void)
{
- ffecomTemp_ temp;
-
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- if (temp->in_use && (temp->t == t))
- {
- assert (!temp->auto_pop);
- temp->in_use = FALSE;
- return;
- }
- else
- assert (temp->t != t);
-
- assert ("couldn't ffecom_pop_tempvar!" != NULL);
+ bison_rule_pushlevel_ ();
}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-#endif
-/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
-
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_ptr_to_expr(expr);
-
- Like ffecom_expr, but sticks address-of in front of most things. */
+/* Public entry point for front end to access start_decl. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_ptr_to_expr (ffebld expr)
+ffecom_start_decl (tree decl, bool is_initialized)
{
- tree item;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffesymbol s;
-
- assert (expr != NULL);
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- ffecomGfrt ix;
-
- ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
- assert (ix != FFECOM_gfrt);
- if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
- {
- ffecom_make_gfrt_ (ix);
- item = ffecom_gfrt_[ix];
- }
- }
- else
- {
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- }
- assert (item != NULL);
- if (item == error_mark_node)
- return item;
- if (!ffesymbol_hook (s).addr)
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
-
- case FFEBLD_opARRAYREF:
- {
- ffebld dims[FFECOM_dimensionsMAX];
- tree array;
- int i;
-
- item = ffecom_ptr_to_expr (ffebld_left (expr));
-
- if (item == error_mark_node)
- return item;
-
- if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
- && !mark_addressable (item))
- return error_mark_node; /* Make sure non-const ref is to
- non-reg. */
-
- /* Build up ARRAY_REFs in reverse order (since we're column major
- here in Fortran land). */
+ DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
+ return start_decl (decl, FALSE);
+}
- for (i = 0, expr = ffebld_right (expr);
- expr != NULL;
- expr = ffebld_trail (expr))
- dims[i++] = ffebld_head (expr);
+#endif
+/* ffecom_sym_commit -- Symbol's state being committed to reality
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- {
- /* The initial subtraction should happen in the original type so
- that (possible) negative values are handled appropriately. */
- 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 (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
- ffecom_expr (dims[i]),
- TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
- }
- }
- return item;
+ ffesymbol s;
+ ffecom_sym_commit(s);
- case FFEBLD_opCONTER:
+ Does whatever the backend needs when a symbol is committed after having
+ been backtrackable for a period of time. */
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_sym_commit (ffesymbol s UNUSED)
+{
+ assert (!ffesymbol_retractable ());
+}
- 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;
+#endif
+/* ffecom_sym_end_transition -- Perform end transition on all symbols
- case FFEBLD_opANY:
- return error_mark_node;
+ ffecom_sym_end_transition();
- default:
- assert (ffecom_pending_calls_ > 0);
+ Does backend-specific stuff and also calls ffest_sym_end_transition
+ to do the necessary FFE stuff.
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
+ Backtracking is never enabled when this fn is called, so don't worry
+ about it. */
- item = ffecom_expr (expr);
- if (item == error_mark_node)
- return error_mark_node;
+ffesymbol
+ffecom_sym_end_transition (ffesymbol s)
+{
+ ffestorag st;
- /* The back end currently optimizes a bit too zealously for us, in that
- we fail JCB001 if the following block of code is omitted. It checks
- to see if the transformed expression is a symbol or array reference,
- and encloses it in a SAVE_EXPR if that is the case. */
+ assert (!ffesymbol_retractable ());
- 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);
- }
+ s = ffest_sym_end_transition (s);
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
+ && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
+ {
+ ffecom_list_blockdata_
+ = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
+ FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE),
+ ffecom_list_blockdata_);
}
-
- assert ("fall-through error" == NULL);
- return error_mark_node;
-}
-
#endif
-/* Prepare to make call-arg temps.
-
- Call this in pairs with pop_calltemps around calls to
- ffecom_arg_ptr_to_expr if the latter might use temporaries. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_push_calltemps ()
-{
- ffecom_pending_calls_++;
-}
-#endif
-/* Obtain a temp var with given data type.
+ /* This is where we finally notice that a symbol has partial initialization
+ and finalize it. */
- Returns a VAR_DECL tree of a currently (that is, at the current
- statement being compiled) not in use and having the given data type,
- making a new one if necessary. size is FFETARGET_charactersizeNONE
- for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
- -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
- ffecom_pop_tempvar won't be called, meaning temp will be freed
- when #pending calls goes to zero. */
+ if (ffesymbol_accretion (s) != NULL)
+ {
+ assert (ffesymbol_init (s) == NULL);
+ ffecom_notify_init_symbol (s);
+ }
+ else if (((st = ffesymbol_storage (s)) != NULL)
+ && ((st = ffestorag_parent (st)) != NULL)
+ && (ffestorag_accretion (st) != NULL))
+ {
+ assert (ffestorag_init (st) == NULL);
+ ffecom_notify_init_storage (st);
+ }
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements,
- bool auto_pop)
-{
- ffecomTemp_ temp;
- int yes;
- tree t;
- static int mynumber;
+ if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
+ && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
+ && (ffesymbol_storage (s) != NULL))
+ {
+ ffecom_list_common_
+ = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
+ FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE),
+ ffecom_list_common_);
+ }
+#endif
- assert (!auto_pop || (ffecom_pending_calls_ > 0));
+ return s;
+}
- if (type == error_mark_node)
- return error_mark_node;
+/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- {
- if (temp->in_use
- || (temp->type != type)
- || (temp->size != size)
- || (temp->elements != elements)
- || (DECL_CONTEXT (temp->t) != current_function_decl))
- continue;
+ ffecom_sym_exec_transition();
- temp->in_use = TRUE;
- temp->auto_pop = auto_pop;
- return temp->t;
- }
+ Does backend-specific stuff and also calls ffest_sym_exec_transition
+ to do the necessary FFE stuff.
- /* Create a new temp. */
+ See the long-winded description in ffecom_sym_learned for info
+ on handling the situation where backtracking is inhibited. */
- yes = suspend_momentary ();
+ffesymbol
+ffecom_sym_exec_transition (ffesymbol s)
+{
+ s = ffest_sym_exec_transition (s);
- if (size != FFETARGET_charactersizeNONE)
- type = build_array_type (type,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- build_int_2 (size, 0)));
- if (elements != -1)
- type = build_array_type (type,
- build_range_type (integer_type_node,
- integer_zero_node,
- build_int_2 (elements - 1,
- 0)));
- t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_expr_%d", NULL,
- mynumber++),
- type);
+ return s;
+}
- /* This temp must be put in the same scope as the containing BLOCK
- (aka function), but for reasons that should be explained elsewhere,
- the GBE normally decides it should be in a "phantom BLOCK" associated
- with the expand_start_stmt_expr() call. So push the topmost
- sequence back onto the GBE's internal stack before telling it
- about the decl, then restore it afterwards. */
- push_topmost_sequence ();
+/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ ffesymbol s;
+ s = ffecom_sym_learned(s);
- pop_topmost_sequence ();
+ Called when a new symbol is seen after the exec transition or when more
+ info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
+ it arrives here is that all its latest info is updated already, so its
+ state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
+ field filled in if its gone through here or exec_transition first, and
+ so on.
- resume_momentary (yes);
+ The backend probably wants to check ffesymbol_retractable() to see if
+ backtracking is in effect. If so, the FFE's changes to the symbol may
+ be retracted (undone) or committed (ratified), at which time the
+ appropriate ffecom_sym_retract or _commit function will be called
+ for that function.
- temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
- sizeof (*temp));
+ If the backend has its own backtracking mechanism, great, use it so that
+ committal is a simple operation. Though it doesn't make much difference,
+ I suppose: the reason for tentative symbol evolution in the FFE is to
+ enable error detection in weird incorrect statements early and to disable
+ incorrect error detection on a correct statement. The backend is not
+ likely to introduce any information that'll get involved in these
+ considerations, so it is probably just fine that the implementation
+ model for this fn and for _exec_transition is to not do anything
+ (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
+ and instead wait until ffecom_sym_commit is called (which it never
+ will be as long as we're using ambiguity-detecting statement analysis in
+ the FFE, which we are initially to shake out the code, but don't depend
+ on this), otherwise go ahead and do whatever is needed.
- temp->next = ffecom_latest_temp_;
- temp->type = type;
- temp->t = t;
- temp->size = size;
- temp->elements = elements;
- temp->in_use = TRUE;
- temp->auto_pop = auto_pop;
+ In essence, then, when this fn and _exec_transition get called while
+ backtracking is enabled, a general mechanism would be to flag which (or
+ both) of these were called (and in what order? neat question as to what
+ might happen that I'm too lame to think through right now) and then when
+ _commit is called reproduce the original calling sequence, if any, for
+ the two fns (at which point backtracking will, of course, be disabled). */
- ffecom_latest_temp_ = temp;
+ffesymbol
+ffecom_sym_learned (ffesymbol s)
+{
+ ffestorag_exec_layout (s);
- return t;
+ return s;
}
-#endif
-/* ffecom_return_expr -- Returns return-value expr given alt return expr
+/* ffecom_sym_retract -- Symbol's state being retracted from reality
- tree rtn; // NULL_TREE means use expand_null_return()
- ffebld expr; // NULL if no alt return expr to RETURN stmt
- rtn = ffecom_return_expr(expr);
+ ffesymbol s;
+ ffecom_sym_retract(s);
- Based on the program unit type and other info (like return function
- type, return master function type when alternate ENTRY points,
- whether subroutine has any alternate RETURN points, etc), returns the
- appropriate expression to be returned to the caller, or NULL_TREE
- meaning no return value or the caller expects it to be returned somewhere
- else (which is handled by other parts of this module). */
+ Does whatever the backend needs when a symbol is retracted after having
+ been backtrackable for a period of time. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_return_expr (ffebld expr)
+void
+ffecom_sym_retract (ffesymbol s UNUSED)
{
- tree rtn;
+ assert (!ffesymbol_retractable ());
- switch (ffecom_primary_entry_kind_)
+#if 0 /* GCC doesn't commit any backtrackable sins,
+ so nothing needed here. */
+ switch (ffesymbol_hook (s).state)
{
- case FFEINFO_kindPROGRAM:
- case FFEINFO_kindBLOCKDATA:
- rtn = NULL_TREE;
+ case 0: /* nothing happened yet. */
break;
- case FFEINFO_kindSUBROUTINE:
- if (!ffecom_is_altreturning_)
- rtn = NULL_TREE; /* No alt returns, never an expr. */
- else if (expr == NULL)
- rtn = integer_zero_node;
- else
- rtn = ffecom_expr (expr);
+ case 1: /* exec transition happened. */
break;
- case FFEINFO_kindFUNCTION:
- if ((ffecom_multi_retval_ != NULL_TREE)
- || (ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCHARACTER)
- || ((ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCOMPLEX)
- && (ffecom_num_entrypoints_ == 0)
- && ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Value is returned by direct assignment
- into (implicit) dummy. */
- rtn = NULL_TREE;
- break;
- }
- rtn = ffecom_func_result_;
-#if 0
- /* Spurious error if RETURN happens before first reference! So elide
- this code. In particular, for debugging registry, rtn should always
- be non-null after all, but TREE_USED won't be set until we encounter
- a reference in the code. Perfectly okay (but weird) code that,
- e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
- this diagnostic for no reason. Have people use -O -Wuninitialized
- and leave it to the back end to find obviously weird cases. */
+ case 2: /* learned happened. */
+ break;
- /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
- situation; if the return value has never been referenced, it won't
- have a tree under 2pass mode. */
- if ((rtn == NULL_TREE)
- || !TREE_USED (rtn))
- {
- ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
- ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
- ffesymbol_where_column (ffecom_primary_entry_));
- ffebad_string (ffesymbol_text (ffesymbol_funcresult
- (ffecom_primary_entry_)));
- ffebad_finish ();
- }
-#endif
+ case 3: /* learned then exec. */
+ break;
+
+ case 4: /* exec then learned. */
break;
default:
- assert ("bad unit kind" == NULL);
- case FFEINFO_kindANY:
- rtn = error_mark_node;
+ assert ("bad hook state" == NULL);
break;
}
+#endif
+}
- return rtn;
+#endif
+/* Create temporary gcc label. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_temp_label ()
+{
+ tree glabel;
+ static int mynumber = 0;
+
+ glabel = build_decl (LABEL_DECL,
+ ffecom_get_invented_identifier ("__g77_label_%d",
+ NULL,
+ mynumber++),
+ void_type_node);
+ DECL_CONTEXT (glabel) = current_function_decl;
+ DECL_MODE (glabel) = VOIDmode;
+
+ return glabel;
}
#endif
-/* Do save_expr only if tree is not error_mark_node. */
+/* Return an expression that is usable as an arg in a conditional context
+ (IF, DO WHILE, .NOT., and so on).
+
+ Use the one provided for the back end as of >2.6.0. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_save_tree (tree t)
+ffecom_truth_value (tree expr)
{
- return save_expr (t);
+ return truthvalue_conversion (expr);
}
+
#endif
+/* Return the inversion of a truth value (the inversion of what
+ ffecom_truth_value builds).
-/* Public entry point for front end to access start_decl. */
+ Apparently invert_truthvalue, which is properly in the back end, is
+ enough for now, so just use it. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_start_decl (tree decl, bool is_initialized)
+ffecom_truth_value_invert (tree expr)
{
- DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
- return start_decl (decl, FALSE);
+ return invert_truthvalue (ffecom_truth_value (expr));
}
#endif
-/* ffecom_sym_commit -- Symbol's state being committed to reality
- ffesymbol s;
- ffecom_sym_commit(s);
+/* Return the tree that is the type of the expression, as would be
+ returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
+ transforming the expression, generating temporaries, etc. */
- Does whatever the backend needs when a symbol is committed after having
- been backtrackable for a period of time. */
+tree
+ffecom_type_expr (ffebld expr)
+{
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ tree tree_type;
+
+ assert (expr != NULL);
+
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ tree_type = ffecom_tree_type[bt][kt];
+
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opCONTER:
+ case FFEBLD_opSYMTER:
+ case FFEBLD_opARRAYREF:
+ case FFEBLD_opUPLUS:
+ case FFEBLD_opPAREN:
+ case FFEBLD_opUMINUS:
+ case FFEBLD_opADD:
+ case FFEBLD_opSUBTRACT:
+ case FFEBLD_opMULTIPLY:
+ case FFEBLD_opDIVIDE:
+ case FFEBLD_opPOWER:
+ case FFEBLD_opNOT:
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opSUBRREF:
+ case FFEBLD_opAND:
+ case FFEBLD_opOR:
+ case FFEBLD_opXOR:
+ case FFEBLD_opNEQV:
+ case FFEBLD_opEQV:
+ case FFEBLD_opCONVERT:
+ case FFEBLD_opLT:
+ case FFEBLD_opLE:
+ case FFEBLD_opEQ:
+ case FFEBLD_opNE:
+ case FFEBLD_opGT:
+ case FFEBLD_opGE:
+ case FFEBLD_opPERCENT_LOC:
+ return tree_type;
+
+ case FFEBLD_opACCTER:
+ case FFEBLD_opARRTER:
+ case FFEBLD_opITEM:
+ case FFEBLD_opSTAR:
+ case FFEBLD_opBOUNDS:
+ case FFEBLD_opREPEAT:
+ case FFEBLD_opLABTER:
+ case FFEBLD_opLABTOK:
+ case FFEBLD_opIMPDO:
+ case FFEBLD_opCONCATENATE:
+ case FFEBLD_opSUBSTR:
+ default:
+ assert ("bad op for ffecom_type_expr" == NULL);
+ /* Fall through. */
+ case FFEBLD_opANY:
+ return error_mark_node;
+ }
+}
+
+/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
+
+ If the PARM_DECL already exists, return it, else create it. It's an
+ integer_type_node argument for the master function that implements a
+ subroutine or function with more than one entrypoint and is bound at
+ run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
+ first ENTRY statement, and so on). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_sym_commit (ffesymbol s UNUSED)
+tree
+ffecom_which_entrypoint_decl ()
{
- assert (!ffesymbol_retractable ());
+ assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
+
+ return ffecom_which_entrypoint_decl_;
}
#endif
-/* ffecom_sym_end_transition -- Perform end transition on all symbols
+\f
+/* The following sections consists of private and public functions
+ that have the same names and perform roughly the same functions
+ as counterparts in the C front end. Changes in the C front end
+ might affect how things should be done here. Only functions
+ needed by the back end should be public here; the rest should
+ be private (static in the C sense). Functions needed by other
+ g77 front-end modules should be accessed by them via public
+ ffecom_* names, which should themselves call private versions
+ in this section so the private versions are easy to recognize
+ when upgrading to a new gcc and finding interesting changes
+ in the front end.
- ffecom_sym_end_transition();
+ Functions named after rule "foo:" in c-parse.y are named
+ "bison_rule_foo_" so they are easy to find. */
- Does backend-specific stuff and also calls ffest_sym_end_transition
- to do the necessary FFE stuff.
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
- Backtracking is never enabled when this fn is called, so don't worry
- about it. */
+static void
+bison_rule_pushlevel_ ()
+{
+ emit_line_note (input_filename, lineno);
+ pushlevel (0);
+ clear_last_expr ();
+ push_momentary ();
+ expand_start_bindings (0);
+}
-ffesymbol
-ffecom_sym_end_transition (ffesymbol s)
+static tree
+bison_rule_compstmt_ ()
{
- ffestorag st;
+ tree t;
+ int keep = kept_level_p ();
- assert (!ffesymbol_retractable ());
+ /* Make the temps go away. */
+ if (! keep)
+ current_binding_level->names = NULL_TREE;
- s = ffest_sym_end_transition (s);
+ emit_line_note (input_filename, lineno);
+ expand_end_bindings (getdecls (), keep, 0);
+ t = poplevel (keep, 1, 0);
+ pop_momentary ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
- && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
- {
- ffecom_list_blockdata_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_blockdata_);
- }
-#endif
+ return t;
+}
- /* This is where we finally notice that a symbol has partial initialization
- and finalize it. */
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
- if (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 LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
- && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
- && (ffesymbol_storage (s) != NULL))
+static tree
+builtin_function (const char *name, tree type,
+ enum built_in_function function_code,
+ const char *library_name)
+{
+ tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ if (library_name)
+ DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
+ make_decl_rtl (decl, NULL_PTR, 1);
+ pushdecl (decl);
+ if (function_code != NOT_BUILT_IN)
{
- ffecom_list_common_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_common_);
+ DECL_BUILT_IN (decl) = 1;
+ DECL_FUNCTION_CODE (decl) = function_code;
}
-#endif
- return s;
+ return decl;
}
-/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
-
- ffecom_sym_exec_transition();
-
- Does backend-specific stuff and also calls ffest_sym_exec_transition
- to do the necessary FFE stuff.
+/* Handle when a new declaration NEWDECL
+ has the same name as an old one OLDDECL
+ in the same binding contour.
+ Prints an error message if appropriate.
- See the long-winded description in ffecom_sym_learned for info
- on handling the situation where backtracking is inhibited. */
+ If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
+ Otherwise, return 0. */
-ffesymbol
-ffecom_sym_exec_transition (ffesymbol s)
+static int
+duplicate_decls (tree newdecl, tree olddecl)
{
- s = ffest_sym_exec_transition (s);
-
- return s;
-}
-
-/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
-
- ffesymbol s;
- s = ffecom_sym_learned(s);
-
- Called when a new symbol is seen after the exec transition or when more
- info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
- it arrives here is that all its latest info is updated already, so its
- state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
- field filled in if its gone through here or exec_transition first, and
- so on.
+ 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);
- The backend probably wants to check ffesymbol_retractable() to see if
- backtracking is in effect. If so, the FFE's changes to the symbol may
- be retracted (undone) or committed (ratified), at which time the
- appropriate ffecom_sym_retract or _commit function will be called
- for that function.
+ if (olddecl == newdecl)
+ return 1;
- If the backend has its own backtracking mechanism, great, use it so that
- committal is a simple operation. Though it doesn't make much difference,
- I suppose: the reason for tentative symbol evolution in the FFE is to
- enable error detection in weird incorrect statements early and to disable
- incorrect error detection on a correct statement. The backend is not
- likely to introduce any information that'll get involved in these
- considerations, so it is probably just fine that the implementation
- model for this fn and for _exec_transition is to not do anything
- (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
- and instead wait until ffecom_sym_commit is called (which it never
- will be as long as we're using ambiguity-detecting statement analysis in
- the FFE, which we are initially to shake out the code, but don't depend
- on this), otherwise go ahead and do whatever is needed.
+ if (TREE_CODE (newtype) == ERROR_MARK
+ || TREE_CODE (oldtype) == ERROR_MARK)
+ types_match = 0;
- In essence, then, when this fn and _exec_transition get called while
- backtracking is enabled, a general mechanism would be to flag which (or
- both) of these were called (and in what order? neat question as to what
- might happen that I'm too lame to think through right now) and then when
- _commit is called reproduce the original calling sequence, if any, for
- the two fns (at which point backtracking will, of course, be disabled). */
+ /* New decl is completely inconsistent with the old one =>
+ tell caller to replace the old one.
+ This is always an error except in the case of shadowing a builtin. */
+ if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
+ return 0;
-ffesymbol
-ffecom_sym_learned (ffesymbol s)
-{
- ffestorag_exec_layout (s);
+ /* For real parm decl following a forward decl,
+ return 1 so old decl will be reused. */
+ if (types_match && TREE_CODE (newdecl) == PARM_DECL
+ && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
+ return 1;
- return s;
-}
+ /* The new declaration is the same kind of object as the old one.
+ The declarations may partially match. Print warnings if they don't
+ match enough. Ultimately, copy most of the information from the new
+ decl to the old one, and keep using the old one. */
-/* ffecom_sym_retract -- Symbol's state being retracted from reality
+ if (TREE_CODE (olddecl) == FUNCTION_DECL
+ && DECL_BUILT_IN (olddecl))
+ {
+ /* A function declaration for a built-in function. */
+ if (!TREE_PUBLIC (newdecl))
+ return 0;
+ else if (!types_match)
+ {
+ /* Accept the return type of the new declaration if same modes. */
+ tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
+ tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
- ffesymbol s;
- ffecom_sym_retract(s);
+ /* Make sure we put the new type in the same obstack as the old ones.
+ If the old types are not both in the same obstack, use the
+ permanent one. */
+ if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
+ push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
+ else
+ {
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ }
- Does whatever the backend needs when a symbol is retracted after having
- been backtrackable for a period of time. */
+ if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
+ {
+ /* Function types may be shared, so we can't just modify
+ the return type of olddecl's function type. */
+ tree newtype
+ = build_function_type (newreturntype,
+ TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_sym_retract (ffesymbol s UNUSED)
-{
- assert (!ffesymbol_retractable ());
+ types_match = 1;
+ if (types_match)
+ TREE_TYPE (olddecl) = newtype;
+ }
-#if 0 /* GCC doesn't commit any backtrackable sins,
- so nothing needed here. */
- switch (ffesymbol_hook (s).state)
+ pop_obstacks ();
+ }
+ if (!types_match)
+ return 0;
+ }
+ else if (TREE_CODE (olddecl) == FUNCTION_DECL
+ && DECL_SOURCE_LINE (olddecl) == 0)
{
- case 0: /* nothing happened yet. */
- break;
+ /* A function declaration for a predeclared function
+ that isn't actually built in. */
+ if (!TREE_PUBLIC (newdecl))
+ return 0;
+ else if (!types_match)
+ {
+ /* If the types don't match, preserve volatility indication.
+ Later on, we will discard everything else about the
+ default declaration. */
+ TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
+ }
+ }
- case 1: /* exec transition happened. */
- break;
+ /* Copy all the DECL_... slots specified in the new decl
+ except for any that we copy here from the old type.
- case 2: /* learned happened. */
- break;
+ Past this point, we don't change OLDTYPE and NEWTYPE
+ even if we change the types of NEWDECL and OLDDECL. */
- case 3: /* learned then exec. */
- break;
+ if (types_match)
+ {
+ /* Make sure we put the new type in the same obstack as the old ones.
+ If the old types are not both in the same obstack, use the permanent
+ one. */
+ if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
+ push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
+ else
+ {
+ push_obstacks_nochange ();
+ end_temporary_allocation ();
+ }
- case 4: /* exec then learned. */
- break;
+ /* Merge the data types specified in the two decls. */
+ if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
+ TREE_TYPE (newdecl)
+ = TREE_TYPE (olddecl)
+ = TREE_TYPE (newdecl);
- default:
- assert ("bad hook state" == NULL);
- break;
- }
-#endif
-}
+ /* Lay the type out, unless already done. */
+ if (oldtype != TREE_TYPE (newdecl))
+ {
+ if (TREE_TYPE (newdecl) != error_mark_node)
+ layout_type (TREE_TYPE (newdecl));
+ if (TREE_CODE (newdecl) != FUNCTION_DECL
+ && TREE_CODE (newdecl) != TYPE_DECL
+ && TREE_CODE (newdecl) != CONST_DECL)
+ layout_decl (newdecl, 0);
+ }
+ else
+ {
+ /* Since the type is OLDDECL's, make OLDDECL's size go with. */
+ DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
+ if (TREE_CODE (olddecl) != FUNCTION_DECL)
+ if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
+ DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ }
-#endif
-/* Create temporary gcc label. */
+ /* Keep the old rtl since we can safely use it. */
+ DECL_RTL (newdecl) = DECL_RTL (olddecl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_temp_label ()
-{
- tree glabel;
- static int mynumber = 0;
+ /* Merge the type qualifiers. */
+ if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
+ && !TREE_THIS_VOLATILE (newdecl))
+ TREE_THIS_VOLATILE (olddecl) = 0;
+ if (TREE_READONLY (newdecl))
+ TREE_READONLY (olddecl) = 1;
+ if (TREE_THIS_VOLATILE (newdecl))
+ {
+ TREE_THIS_VOLATILE (olddecl) = 1;
+ if (TREE_CODE (newdecl) == VAR_DECL)
+ make_var_volatile (newdecl);
+ }
- glabel = build_decl (LABEL_DECL,
- ffecom_get_invented_identifier ("__g77_label_%d",
- NULL,
- mynumber++),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
+ /* Keep source location of definition rather than declaration.
+ Likewise, keep decl at outer scope. */
+ if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
+ || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
+ {
+ DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
+ DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
- return glabel;
-}
+ if (DECL_CONTEXT (olddecl) == 0
+ && TREE_CODE (newdecl) != FUNCTION_DECL)
+ DECL_CONTEXT (newdecl) = 0;
+ }
-#endif
-/* Return an expression that is usable as an arg in a conditional context
- (IF, DO WHILE, .NOT., and so on).
+ /* Merge the unused-warning information. */
+ if (DECL_IN_SYSTEM_HEADER (olddecl))
+ DECL_IN_SYSTEM_HEADER (newdecl) = 1;
+ else if (DECL_IN_SYSTEM_HEADER (newdecl))
+ DECL_IN_SYSTEM_HEADER (olddecl) = 1;
- Use the one provided for the back end as of >2.6.0. */
+ /* Merge the initialization information. */
+ if (DECL_INITIAL (newdecl) == 0)
+ DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_truth_value (tree expr)
-{
- return truthvalue_conversion (expr);
-}
+ /* Merge the section attribute.
+ We want to issue an error if the sections conflict but that must be
+ done later in decl_attributes since we are called before attributes
+ are assigned. */
+ if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
+ DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
+#if BUILT_FOR_270
+ if (TREE_CODE (newdecl) == FUNCTION_DECL)
+ {
+ DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
+ DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
+ }
#endif
-/* Return the inversion of a truth value (the inversion of what
- ffecom_truth_value builds).
- Apparently invert_truthvalue, which is properly in the back end, is
- enough for now, so just use it. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_truth_value_invert (tree expr)
-{
- return invert_truthvalue (ffecom_truth_value (expr));
-}
+ pop_obstacks ();
+ }
+ /* If cannot merge, then use the new type and qualifiers,
+ and don't preserve the old rtl. */
+ else
+ {
+ TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
+ TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
+ TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
+ TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
+ }
-#endif
-/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
+ /* Merge the storage class information. */
+ /* For functions, static overrides non-static. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL)
+ {
+ TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
+ /* This is since we don't automatically
+ copy the attributes of NEWDECL into OLDDECL. */
+ TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
+ /* If this clears `static', clear it in the identifier too. */
+ if (! TREE_PUBLIC (olddecl))
+ TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
+ }
+ if (DECL_EXTERNAL (newdecl))
+ {
+ TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
+ DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
+ /* An extern decl does not override previous storage class. */
+ TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
+ }
+ else
+ {
+ TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
+ TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
+ }
- If the PARM_DECL already exists, return it, else create it. It's an
- integer_type_node argument for the master function that implements a
- subroutine or function with more than one entrypoint and is bound at
- run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
- first ENTRY statement, and so on). */
+ /* If either decl says `inline', this fn is inline,
+ unless its definition was passed already. */
+ if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
+ DECL_INLINE (olddecl) = 1;
+ DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_which_entrypoint_decl ()
-{
- assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
+ /* Get rid of any built-in function if new arg types don't match it
+ or if we have a function definition. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL
+ && DECL_BUILT_IN (olddecl)
+ && (!types_match || new_is_definition))
+ {
+ TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
+ DECL_BUILT_IN (olddecl) = 0;
+ }
- return ffecom_which_entrypoint_decl_;
-}
+ /* If redeclaring a builtin function, and not a definition,
+ it stays built in.
+ Also preserve various other info from the definition. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
+ {
+ if (DECL_BUILT_IN (olddecl))
+ {
+ DECL_BUILT_IN (newdecl) = 1;
+ DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
+ }
+ else
+ DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
-#endif
-\f
-/* The following sections consists of private and public functions
- that have the same names and perform roughly the same functions
- as counterparts in the C front end. Changes in the C front end
- might affect how things should be done here. Only functions
- needed by the back end should be public here; the rest should
- be private (static in the C sense). Functions needed by other
- g77 front-end modules should be accessed by them via public
- ffecom_* names, which should themselves call private versions
- in this section so the private versions are easy to recognize
- when upgrading to a new gcc and finding interesting changes
- in the front end.
+ 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);
+ }
- Functions named after rule "foo:" in c-parse.y are named
- "bison_rule_foo_" so they are easy to find. */
+ /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
+ But preserve olddecl's DECL_UID. */
+ {
+ register unsigned olddecl_uid = DECL_UID (olddecl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ 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;
+ }
-static void
-bison_rule_compstmt_ ()
-{
- emit_line_note (input_filename, lineno);
- expand_end_bindings (getdecls (), 1, 1);
- poplevel (1, 1, 0);
- pop_momentary ();
+ return 1;
}
+/* Finish processing of a declaration;
+ install its initial value.
+ If the length of an array type is not known before,
+ it must be determined now, from the initial value, or it is an error. */
+
static void
-bison_rule_pushlevel_ ()
+finish_decl (tree decl, tree init, bool is_top_level)
{
- emit_line_note (input_filename, lineno);
- pushlevel (0);
- clear_last_expr ();
- push_momentary ();
- expand_start_bindings (0);
-}
+ register tree type = TREE_TYPE (decl);
+ int was_incomplete = (DECL_SIZE (decl) == 0);
+ int temporary = allocation_temporary_p ();
+ bool at_top_level = (current_binding_level == global_binding_level);
+ bool top_level = is_top_level || at_top_level;
-/* Return a definition for a builtin function named NAME and whose data type
- is TYPE. TYPE should be a function type with argument types.
- FUNCTION_CODE tells later passes how to compile calls to this function.
- See tree.h for its possible values.
+ /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
+ level anyway. */
+ assert (!is_top_level || !at_top_level);
- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
- the name to be called if we can't opencode the function. */
+ if (TREE_CODE (decl) == PARM_DECL)
+ assert (init == NULL_TREE);
+ /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
+ overlaps DECL_ARG_TYPE. */
+ else if (init == NULL_TREE)
+ assert (DECL_INITIAL (decl) == NULL_TREE);
+ else
+ assert (DECL_INITIAL (decl) == error_mark_node);
-static tree
-builtin_function (const char *name, tree type,
- enum built_in_function function_code,
- const char *library_name)
-{
- tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
- DECL_EXTERNAL (decl) = 1;
- TREE_PUBLIC (decl) = 1;
- if (library_name)
- DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
- make_decl_rtl (decl, NULL_PTR, 1);
- pushdecl (decl);
- if (function_code != NOT_BUILT_IN)
+ if (init != NULL_TREE)
{
- DECL_BUILT_IN (decl) = 1;
- DECL_FUNCTION_CODE (decl) = function_code;
+ if (TREE_CODE (decl) != TYPE_DECL)
+ DECL_INITIAL (decl) = init;
+ else
+ {
+ /* typedef foo = bar; store the type of bar as the type of foo. */
+ TREE_TYPE (decl) = TREE_TYPE (init);
+ DECL_INITIAL (decl) = init = 0;
+ }
}
- return decl;
-}
-
-/* Handle when a new declaration NEWDECL
- has the same name as an old one OLDDECL
- in the same binding contour.
- Prints an error message if appropriate.
+ /* Pop back to the obstack that is current for this binding level. This is
+ because MAXINDEX, rtl, etc. to be made below must go in the permanent
+ obstack. But don't discard the temporary data yet. */
+ pop_obstacks ();
- If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
- Otherwise, return 0. */
+ /* Deduce size of array from initialization, if not already known */
-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 (TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_DOMAIN (type) == 0
+ && TREE_CODE (decl) != TYPE_DECL)
+ {
+ assert (top_level);
+ assert (was_incomplete);
- if (olddecl == newdecl)
- return 1;
+ layout_decl (decl, 0);
+ }
- if (TREE_CODE (newtype) == ERROR_MARK
- || TREE_CODE (oldtype) == ERROR_MARK)
- types_match = 0;
+ if (TREE_CODE (decl) == VAR_DECL)
+ {
+ if (DECL_SIZE (decl) == NULL_TREE
+ && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
+ layout_decl (decl, 0);
- /* New decl is completely inconsistent with the old one =>
- tell caller to replace the old one.
- This is always an error except in the case of shadowing a builtin. */
- if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
- return 0;
+ if (DECL_SIZE (decl) == NULL_TREE
+ && (TREE_STATIC (decl)
+ ?
+ /* A static variable with an incomplete type is an error if it is
+ initialized. Also if it is not file scope. Otherwise, let it
+ through, but if it is not `extern' then it may cause an error
+ message later. */
+ (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
+ :
+ /* An automatic variable with an incomplete type is an error. */
+ !DECL_EXTERNAL (decl)))
+ {
+ assert ("storage size not known" == NULL);
+ abort ();
+ }
- /* For real parm decl following a forward decl,
- return 1 so old decl will be reused. */
- if (types_match && TREE_CODE (newdecl) == PARM_DECL
- && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
- return 1;
+ 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 ();
+ }
+ }
- /* The new declaration is the same kind of object as the old one.
- The declarations may partially match. Print warnings if they don't
- match enough. Ultimately, copy most of the information from the new
- decl to the old one, and keep using the old one. */
+ /* Output the assembler code and/or RTL code for variables and functions,
+ unless the type is an undefined structure or union. If not, it will get
+ done when the type is completed. */
- if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl))
+ if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
{
- /* A function declaration for a built-in function. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
- {
- /* Accept the return type of the new declaration if same modes. */
- tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
- tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
+ rest_of_decl_compilation (decl, NULL,
+ DECL_CONTEXT (decl) == 0,
+ 0);
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the
- permanent one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
+ if (DECL_CONTEXT (decl) != 0)
+ {
+ /* Recompute the RTL of a local array now if it used to be an
+ incomplete type. */
+ if (was_incomplete
+ && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
{
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ /* If we used it already as memory, it must stay in memory. */
+ TREE_ADDRESSABLE (decl) = TREE_USED (decl);
+ /* If it's still incomplete now, no init will save it. */
+ if (DECL_SIZE (decl) == 0)
+ DECL_INITIAL (decl) = 0;
+ expand_decl (decl);
}
+ /* Compute and store the initial value. */
+ if (TREE_CODE (decl) != FUNCTION_DECL)
+ expand_decl_init (decl);
+ }
+ }
+ else if (TREE_CODE (decl) == TYPE_DECL)
+ {
+ rest_of_decl_compilation (decl, NULL_PTR,
+ DECL_CONTEXT (decl) == 0,
+ 0);
+ }
- if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
+ /* This test used to include TREE_PERMANENT, however, we have the same
+ problem with initializers at the function level. Such initializers get
+ saved until the end of the function on the momentary_obstack. */
+ if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
+ && temporary
+ /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
+ DECL_ARG_TYPE. */
+ && TREE_CODE (decl) != PARM_DECL)
+ {
+ /* We need to remember that this array HAD an initialization, but
+ discard the actual temporary nodes, since we can't have a permanent
+ node keep pointing to them. */
+ /* We make an exception for inline functions, since it's normal for a
+ local extern redeclaration of an inline function to have a copy of
+ the top-level decl's DECL_INLINE. */
+ if ((DECL_INITIAL (decl) != 0)
+ && (DECL_INITIAL (decl) != error_mark_node))
+ {
+ /* If this is a const variable, then preserve the
+ initializer instead of discarding it so that we can optimize
+ references to it. */
+ /* This test used to include TREE_STATIC, but this won't be set
+ for function level initializers. */
+ if (TREE_READONLY (decl))
{
- /* Function types may be shared, so we can't just modify
- the return type of olddecl's function type. */
- tree newtype
- = build_function_type (newreturntype,
- TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
+ preserve_initializer ();
+ /* Hack? Set the permanent bit for something that is
+ permanent, but not on the permenent obstack, so as to
+ convince output_constant_def to make its rtl on the
+ permanent obstack. */
+ TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
- types_match = 1;
- if (types_match)
- TREE_TYPE (olddecl) = newtype;
+ /* The initializer and DECL must have the same (or equivalent
+ types), but if the initializer is a STRING_CST, its type
+ might not be on the right obstack, so copy the type
+ of DECL. */
+ TREE_TYPE (DECL_INITIAL (decl)) = type;
}
-
- pop_obstacks ();
+ else
+ DECL_INITIAL (decl) = error_mark_node;
}
- if (!types_match)
- return 0;
}
- else if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_SOURCE_LINE (olddecl) == 0)
+
+ /* If requested, warn about definitions of large data objects. */
+
+ if (warn_larger_than
+ && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
+ && !DECL_EXTERNAL (decl))
{
- /* A function declaration for a predeclared function
- that isn't actually built in. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
+ register tree decl_size = DECL_SIZE (decl);
+
+ if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
{
- /* If the types don't match, preserve volatility indication.
- Later on, we will discard everything else about the
- default declaration. */
- TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
+ unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
+
+ if (units > larger_than_size)
+ warning_with_decl (decl, "size of `%s' is %u bytes", units);
}
}
- /* Copy all the DECL_... slots specified in the new decl
- except for any that we copy here from the old type.
+ /* If we have gone back from temporary to permanent allocation, actually
+ free the temporary space that we no longer need. */
+ if (temporary && !allocation_temporary_p ())
+ permanent_allocation (0);
- Past this point, we don't change OLDTYPE and NEWTYPE
- even if we change the types of NEWDECL and OLDDECL. */
+ /* At the end of a declaration, throw away any variable type sizes of types
+ defined inside that declaration. There is no use computing them in the
+ following function definition. */
+ if (current_binding_level == global_binding_level)
+ get_pending_sizes ();
+}
- if (types_match)
- {
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the permanent
- one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
+/* Finish up a function declaration and compile that function
+ all the way to assembler language output. The free the storage
+ for the function definition.
- /* Merge the data types specified in the two decls. */
- if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
- TREE_TYPE (newdecl)
- = TREE_TYPE (olddecl)
- = TREE_TYPE (newdecl);
+ This is called after parsing the body of the function definition.
- /* Lay the type out, unless already done. */
- if (oldtype != TREE_TYPE (newdecl))
- {
- if (TREE_TYPE (newdecl) != error_mark_node)
- layout_type (TREE_TYPE (newdecl));
- if (TREE_CODE (newdecl) != FUNCTION_DECL
- && TREE_CODE (newdecl) != TYPE_DECL
- && TREE_CODE (newdecl) != CONST_DECL)
- layout_decl (newdecl, 0);
- }
+ NESTED is nonzero if the function being finished is nested in another. */
+
+static void
+finish_function (int nested)
+{
+ register tree fndecl = current_function_decl;
+
+ assert (fndecl != NULL_TREE);
+ if (TREE_CODE (fndecl) != ERROR_MARK)
+ {
+ if (nested)
+ assert (DECL_CONTEXT (fndecl) != NULL_TREE);
else
- {
- /* Since the type is OLDDECL's, make OLDDECL's size go with. */
- DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
- if (TREE_CODE (olddecl) != FUNCTION_DECL)
- if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
- DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
- }
+ assert (DECL_CONTEXT (fndecl) == NULL_TREE);
+ }
- /* Keep the old rtl since we can safely use it. */
- DECL_RTL (newdecl) = DECL_RTL (olddecl);
+/* TREE_READONLY (fndecl) = 1;
+ This caused &foo to be of type ptr-to-const-function
+ which then got a warning when stored in a ptr-to-function variable. */
- /* Merge the type qualifiers. */
- if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
- && !TREE_THIS_VOLATILE (newdecl))
- TREE_THIS_VOLATILE (olddecl) = 0;
- if (TREE_READONLY (newdecl))
- TREE_READONLY (olddecl) = 1;
- if (TREE_THIS_VOLATILE (newdecl))
- {
- TREE_THIS_VOLATILE (olddecl) = 1;
- if (TREE_CODE (newdecl) == VAR_DECL)
- make_var_volatile (newdecl);
- }
+ poplevel (1, 0, 1);
- /* Keep source location of definition rather than declaration.
- Likewise, keep decl at outer scope. */
- if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
- || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
- {
- DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
- DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
+ if (TREE_CODE (fndecl) != ERROR_MARK)
+ {
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
- if (DECL_CONTEXT (olddecl) == 0
- && TREE_CODE (newdecl) != FUNCTION_DECL)
- DECL_CONTEXT (newdecl) = 0;
- }
+ /* Must mark the RESULT_DECL as being in this function. */
- /* Merge the unused-warning information. */
- if (DECL_IN_SYSTEM_HEADER (olddecl))
- DECL_IN_SYSTEM_HEADER (newdecl) = 1;
- else if (DECL_IN_SYSTEM_HEADER (newdecl))
- DECL_IN_SYSTEM_HEADER (olddecl) = 1;
+ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
- /* Merge the initialization information. */
- if (DECL_INITIAL (newdecl) == 0)
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
+ /* Obey `register' declarations if `setjmp' is called in this fn. */
+ /* Generate rtl for function exit. */
+ expand_function_end (input_filename, lineno, 0);
- /* Merge the section attribute.
- We want to issue an error if the sections conflict but that must be
- done later in decl_attributes since we are called before attributes
- are assigned. */
- if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
- DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
+ /* So we can tell if jump_optimize sets it to 1. */
+ can_reach_end = 0;
-#if BUILT_FOR_270
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
- {
- DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
- DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
- }
-#endif
+ /* Run the optimizers and output the assembler code for this function. */
+ rest_of_compilation (fndecl);
+ }
- pop_obstacks ();
+ /* Free all the tree nodes making up this function. */
+ /* Switch back to allocating nodes permanently until we start another
+ function. */
+ if (!nested)
+ permanent_allocation (1);
+
+ if (TREE_CODE (fndecl) != ERROR_MARK
+ && !nested
+ && DECL_SAVED_INSNS (fndecl) == 0)
+ {
+ /* Stop pointing to the local nodes about to be freed. */
+ /* But DECL_INITIAL must remain nonzero so we know this was an actual
+ function definition. */
+ /* For a nested function, this is done in pop_f_function_context. */
+ /* If rest_of_compilation set this to 0, leave it 0. */
+ if (DECL_INITIAL (fndecl) != 0)
+ DECL_INITIAL (fndecl) = error_mark_node;
+ DECL_ARGUMENTS (fndecl) = 0;
}
- /* If cannot merge, then use the new type and qualifiers,
- and don't preserve the old rtl. */
- else
+
+ if (!nested)
{
- 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);
+ /* Let the error reporting routines know that we're outside a function.
+ For a nested function, this value is used in pop_c_function_context
+ and then reset via pop_function_context. */
+ ffecom_outer_function_decl_ = current_function_decl = NULL;
}
+}
- /* Merge the storage class information. */
- /* For functions, static overrides non-static. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
+/* Plug-in replacement for identifying the name of a decl and, for a
+ function, what we call it in diagnostics. For now, "program unit"
+ should suffice, since it's a bit of a hassle to figure out which
+ of several kinds of things it is. Note that it could conceivably
+ be a statement function, which probably isn't really a program unit
+ per se, but if that comes up, it should be easy to check (being a
+ nested function and all). */
+
+static char *
+lang_printable_name (tree decl, int v)
+{
+ /* Just to keep GCC quiet about the unused variable.
+ In theory, differing values of V should produce different
+ output. */
+ switch (v)
{
- TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
- /* This is since we don't automatically
- copy the attributes of NEWDECL into OLDDECL. */
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- /* If this clears `static', clear it in the identifier too. */
- if (! TREE_PUBLIC (olddecl))
- TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
+ default:
+ if (TREE_CODE (decl) == ERROR_MARK)
+ return "erroneous code";
+ return IDENTIFIER_POINTER (DECL_NAME (decl));
}
- if (DECL_EXTERNAL (newdecl))
+}
+
+/* g77's function to print out name of current function that caused
+ an error. */
+
+#if BUILT_FOR_270
+void
+lang_print_error_function (file)
+ char *file;
+{
+ static 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))
{
- TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
- DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
- /* An extern decl does not override previous storage class. */
- TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
+ g = NULL;
+ s = NULL;
+ kind = NULL;
}
else
{
- TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- }
+ g = ffesymbol_global (ffecom_primary_entry_);
+ if (ffecom_nested_entry_ == NULL)
+ {
+ s = ffecom_primary_entry_;
+ switch (ffesymbol_kind (s))
+ {
+ case FFEINFO_kindFUNCTION:
+ kind = "function";
+ break;
- /* If either decl says `inline', this fn is inline,
- unless its definition was passed already. */
- if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
- DECL_INLINE (olddecl) = 1;
- DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
+ case FFEINFO_kindSUBROUTINE:
+ kind = "subroutine";
+ break;
- /* Get rid of any built-in function if new arg types don't match it
- or if we have a function definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl)
- && (!types_match || new_is_definition))
- {
- TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- DECL_BUILT_IN (olddecl) = 0;
+ case FFEINFO_kindPROGRAM:
+ kind = "program";
+ break;
+
+ case FFEINFO_kindBLOCKDATA:
+ kind = "block-data";
+ break;
+
+ default:
+ kind = ffeinfo_kind_message (ffesymbol_kind (s));
+ break;
+ }
+ }
+ else
+ {
+ s = ffecom_nested_entry_;
+ kind = "statement function";
+ }
}
- /* If redeclaring a builtin function, and not a definition,
- it stays built in.
- Also preserve various other info from the definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
+ if ((last_g != g) || (last_s != s))
{
- if (DECL_BUILT_IN (olddecl))
+ if (file)
+ fprintf (stderr, "%s: ", file);
+
+ if (s == NULL)
+ fprintf (stderr, "Outside of any program unit:\n");
+ else
{
- DECL_BUILT_IN (newdecl) = 1;
- DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
+ const char *name = ffesymbol_text (s);
+
+ fprintf (stderr, "In %s `%s':\n", kind, name);
}
- else
- DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
- DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
- DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
- DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
+ last_g = g;
+ last_s = s;
}
+}
+#endif
- /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
- But preserve olddecl's DECL_UID. */
- {
- register unsigned olddecl_uid = DECL_UID (olddecl);
+/* Similar to `lookup_name' but look only at current binding level. */
- 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;
- }
+static tree
+lookup_name_current_level (tree name)
+{
+ register tree t;
- return 1;
+ 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;
}
-/* Finish processing of a declaration;
- install its initial value.
- If the length of an array type is not known before,
- it must be determined now, from the initial value, or it is an error. */
+/* Create a new `struct binding_level'. */
-static void
-finish_decl (tree decl, tree init, bool is_top_level)
+static struct binding_level *
+make_binding_level ()
{
- register tree type = TREE_TYPE (decl);
- int was_incomplete = (DECL_SIZE (decl) == 0);
- int temporary = allocation_temporary_p ();
- bool at_top_level = (current_binding_level == global_binding_level);
- bool top_level = is_top_level || at_top_level;
+ /* NOSTRICT */
+ return (struct binding_level *) xmalloc (sizeof (struct binding_level));
+}
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
+/* Save and restore the variables in this file and elsewhere
+ that keep track of the progress of compilation of the current function.
+ Used for nested functions. */
- if (TREE_CODE (decl) == PARM_DECL)
- assert (init == NULL_TREE);
- /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
- overlaps DECL_ARG_TYPE. */
- else if (init == NULL_TREE)
- assert (DECL_INITIAL (decl) == NULL_TREE);
- else
- assert (DECL_INITIAL (decl) == error_mark_node);
+struct f_function
+{
+ struct f_function *next;
+ tree named_labels;
+ tree shadowed_labels;
+ struct binding_level *binding_level;
+};
- if (init != NULL_TREE)
- {
- if (TREE_CODE (decl) != TYPE_DECL)
- DECL_INITIAL (decl) = init;
- else
- {
- /* typedef foo = bar; store the type of bar as the type of foo. */
- TREE_TYPE (decl) = TREE_TYPE (init);
- DECL_INITIAL (decl) = init = 0;
- }
- }
+struct f_function *f_function_chain;
- /* Pop back to the obstack that is current for this binding level. This is
- because MAXINDEX, rtl, etc. to be made below must go in the permanent
- obstack. But don't discard the temporary data yet. */
- pop_obstacks ();
+/* Restore the variables used during compilation of a C function. */
- /* Deduce size of array from initialization, if not already known */
+static void
+pop_f_function_context ()
+{
+ struct f_function *p = f_function_chain;
+ tree link;
- if (TREE_CODE (type) == ARRAY_TYPE
- && TYPE_DOMAIN (type) == 0
- && TREE_CODE (decl) != TYPE_DECL)
- {
- assert (top_level);
- assert (was_incomplete);
+ /* Bring back all the labels that were shadowed. */
+ for (link = shadowed_labels; link; link = TREE_CHAIN (link))
+ if (DECL_NAME (TREE_VALUE (link)) != 0)
+ IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
+ = TREE_VALUE (link);
- layout_decl (decl, 0);
+ if (current_function_decl != error_mark_node
+ && DECL_SAVED_INSNS (current_function_decl) == 0)
+ {
+ /* Stop pointing to the local nodes about to be freed. */
+ /* But DECL_INITIAL must remain nonzero so we know this was an actual
+ function definition. */
+ DECL_INITIAL (current_function_decl) = error_mark_node;
+ DECL_ARGUMENTS (current_function_decl) = 0;
}
- if (TREE_CODE (decl) == VAR_DECL)
- {
- if (DECL_SIZE (decl) == NULL_TREE
- && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
- layout_decl (decl, 0);
+ pop_function_context ();
- if (DECL_SIZE (decl) == NULL_TREE
- && (TREE_STATIC (decl)
- ?
- /* A static variable with an incomplete type is an error if it is
- initialized. Also if it is not file scope. Otherwise, let it
- through, but if it is not `extern' then it may cause an error
- message later. */
- (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
- :
- /* An automatic variable with an incomplete type is an error. */
- !DECL_EXTERNAL (decl)))
- {
- assert ("storage size not known" == NULL);
- abort ();
- }
+ f_function_chain = p->next;
- 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 ();
- }
- }
+ named_labels = p->named_labels;
+ shadowed_labels = p->shadowed_labels;
+ current_binding_level = p->binding_level;
- /* Output the assembler code and/or RTL code for variables and functions,
- unless the type is an undefined structure or union. If not, it will get
- done when the type is completed. */
+ free (p);
+}
- if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
- {
- rest_of_decl_compilation (decl, NULL,
- DECL_CONTEXT (decl) == 0,
- 0);
+/* Save and reinitialize the variables
+ used during compilation of a C function. */
- if (DECL_CONTEXT (decl) != 0)
- {
- /* Recompute the RTL of a local array now if it used to be an
- incomplete type. */
- if (was_incomplete
- && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
- {
- /* If we used it already as memory, it must stay in memory. */
- TREE_ADDRESSABLE (decl) = TREE_USED (decl);
- /* If it's still incomplete now, no init will save it. */
- if (DECL_SIZE (decl) == 0)
- DECL_INITIAL (decl) = 0;
- expand_decl (decl);
- }
- /* Compute and store the initial value. */
- if (TREE_CODE (decl) != FUNCTION_DECL)
- expand_decl_init (decl);
- }
- }
- else if (TREE_CODE (decl) == TYPE_DECL)
- {
- rest_of_decl_compilation (decl, NULL_PTR,
- DECL_CONTEXT (decl) == 0,
- 0);
- }
+static void
+push_f_function_context ()
+{
+ struct f_function *p
+ = (struct f_function *) xmalloc (sizeof (struct f_function));
- /* This test used to include TREE_PERMANENT, however, we have the same
- problem with initializers at the function level. Such initializers get
- saved until the end of the function on the momentary_obstack. */
- if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
- && temporary
- /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
- DECL_ARG_TYPE. */
- && TREE_CODE (decl) != PARM_DECL)
- {
- /* We need to remember that this array HAD an initialization, but
- discard the actual temporary nodes, since we can't have a permanent
- node keep pointing to them. */
- /* We make an exception for inline functions, since it's normal for a
- local extern redeclaration of an inline function to have a copy of
- the top-level decl's DECL_INLINE. */
- if ((DECL_INITIAL (decl) != 0)
- && (DECL_INITIAL (decl) != error_mark_node))
- {
- /* If this is a const variable, then preserve the
- initializer instead of discarding it so that we can optimize
- references to it. */
- /* This test used to include TREE_STATIC, but this won't be set
- for function level initializers. */
- if (TREE_READONLY (decl))
- {
- preserve_initializer ();
- /* Hack? Set the permanent bit for something that is
- permanent, but not on the permenent obstack, so as to
- convince output_constant_def to make its rtl on the
- permanent obstack. */
- TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
+ 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;
+}
- /* The initializer and DECL must have the same (or equivalent
- types), but if the initializer is a STRING_CST, its type
- might not be on the right obstack, so copy the type
- of DECL. */
- TREE_TYPE (DECL_INITIAL (decl)) = type;
- }
- else
- DECL_INITIAL (decl) = error_mark_node;
- }
- }
+static void
+push_parm_decl (tree parm)
+{
+ int old_immediate_size_expand = immediate_size_expand;
- /* If requested, warn about definitions of large data objects. */
+ /* Don't try computing parm sizes now -- wait till fn is called. */
- if (warn_larger_than
- && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
- && !DECL_EXTERNAL (decl))
- {
- register tree decl_size = DECL_SIZE (decl);
+ immediate_size_expand = 0;
- if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
- {
- unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
+ push_obstacks_nochange ();
- if (units > larger_than_size)
- warning_with_decl (decl, "size of `%s' is %u bytes", units);
- }
- }
+ /* Fill in arg stuff. */
- /* If we have gone back from temporary to permanent allocation, actually
- free the temporary space that we no longer need. */
- if (temporary && !allocation_temporary_p ())
- permanent_allocation (0);
+ DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
+ DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
+ TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
- /* At the end of a declaration, throw away any variable type sizes of types
- defined inside that declaration. There is no use computing them in the
- following function definition. */
- if (current_binding_level == global_binding_level)
- get_pending_sizes ();
+ parm = pushdecl (parm);
+
+ immediate_size_expand = old_immediate_size_expand;
+
+ finish_decl (parm, NULL_TREE, FALSE);
}
-/* Finish up a function declaration and compile that function
- all the way to assembler language output. The free the storage
- for the function definition.
+/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
- This is called after parsing the body of the function definition.
+static tree
+pushdecl_top_level (x)
+ tree x;
+{
+ register tree t;
+ register struct binding_level *b = current_binding_level;
+ register tree f = current_function_decl;
- NESTED is nonzero if the function being finished is nested in another. */
+ current_binding_level = global_binding_level;
+ current_function_decl = NULL_TREE;
+ t = pushdecl (x);
+ current_binding_level = b;
+ current_function_decl = f;
+ return t;
+}
+
+/* Store the list of declarations of the current level.
+ This is done for the parameter declarations of a function being defined,
+ after they are modified in the light of any missing parameters. */
+
+static tree
+storedecls (decls)
+ tree decls;
+{
+ return current_binding_level->names = decls;
+}
+
+/* Store the parameter declarations into the current function declaration.
+ This is called after parsing the parameter declarations, before
+ digesting the body of the function.
+
+ For an old-style definition, modify the function's type
+ to specify at least the number of arguments. */
static void
-finish_function (int nested)
+store_parm_decls (int is_main_program UNUSED)
{
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);
- }
+ if (fndecl == error_mark_node)
+ return;
-/* TREE_READONLY (fndecl) = 1;
- This caused &foo to be of type ptr-to-const-function
- which then got a warning when stored in a ptr-to-function variable. */
+ /* This is a chain of PARM_DECLs from old-style parm declarations. */
+ DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
- poplevel (1, 0, 1);
+ /* Initialize the RTL code for the function. */
- if (TREE_CODE (fndecl) != ERROR_MARK)
- {
- BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ init_function_start (fndecl, input_filename, lineno);
- /* Must mark the RESULT_DECL as being in this function. */
+ /* Set up parameters and prepare for return, for the function. */
- DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
+ expand_function_start (fndecl, 0);
+}
- /* Obey `register' declarations if `setjmp' is called in this fn. */
- /* Generate rtl for function exit. */
- expand_function_end (input_filename, lineno, 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;
- /* So we can tell if jump_optimize sets it to 1. */
- can_reach_end = 0;
+ /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
+ level anyway. */
+ assert (!is_top_level || !at_top_level);
- /* Run the optimizers and output the assembler code for this function. */
- rest_of_compilation (fndecl);
+ /* The corresponding pop_obstacks is in finish_decl. */
+ push_obstacks_nochange ();
+
+ if (DECL_INITIAL (decl) != NULL_TREE)
+ {
+ assert (DECL_INITIAL (decl) == error_mark_node);
+ assert (!DECL_EXTERNAL (decl));
}
+ else if (top_level)
+ assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
- /* Free all the tree nodes making up this function. */
- /* Switch back to allocating nodes permanently until we start another
- function. */
- if (!nested)
- permanent_allocation (1);
+ /* For Fortran, we by default put things in .common when possible. */
+ DECL_COMMON (decl) = 1;
- if (TREE_CODE (fndecl) != ERROR_MARK
- && !nested
- && DECL_SAVED_INSNS (fndecl) == 0)
+ /* Add this decl to the current binding level. TEM may equal DECL or it may
+ be a previous decl of the same name. */
+ if (is_top_level)
+ tem = pushdecl_top_level (decl);
+ else
+ tem = pushdecl (decl);
+
+ /* For a local variable, define the RTL now. */
+ if (!top_level
+ /* But not if this is a duplicate decl and we preserved the rtl from the
+ previous one (which may or may not happen). */
+ && DECL_RTL (tem) == 0)
{
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- /* For a nested function, this is done in pop_f_function_context. */
- /* If rest_of_compilation set this to 0, leave it 0. */
- if (DECL_INITIAL (fndecl) != 0)
- DECL_INITIAL (fndecl) = error_mark_node;
- DECL_ARGUMENTS (fndecl) = 0;
+ if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
+ expand_decl (tem);
+ else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
+ && DECL_INITIAL (tem) != 0)
+ expand_decl (tem);
}
- if (!nested)
+ if (DECL_INITIAL (tem) != NULL_TREE)
{
- /* Let the error reporting routines know that we're outside a function.
- For a nested function, this value is used in pop_c_function_context
- and then reset via pop_function_context. */
- ffecom_outer_function_decl_ = current_function_decl = NULL;
+ /* When parsing and digesting the initializer, use temporary storage.
+ Do this even if we will ignore the value. */
+ if (at_top_level)
+ temporary_allocation ();
}
+
+ return tem;
}
-/* Plug-in replacement for identifying the name of a decl and, for a
- function, what we call it in diagnostics. For now, "program unit"
- should suffice, since it's a bit of a hassle to figure out which
- of several kinds of things it is. Note that it could conceivably
- be a statement function, which probably isn't really a program unit
- per se, but if that comes up, it should be easy to check (being a
- nested function and all). */
+/* Create the FUNCTION_DECL for a function definition.
+ DECLSPECS and DECLARATOR are the parts of the declaration;
+ they describe the function's name and the type it returns,
+ but twisted together in a fashion that parallels the syntax of C.
-static char *
-lang_printable_name (tree decl, int v)
-{
- /* Just to keep GCC quiet about the unused variable.
- In theory, differing values of V should produce different
- output. */
- switch (v)
- {
- default:
- if (TREE_CODE (decl) == ERROR_MARK)
- return "erroneous code";
- return IDENTIFIER_POINTER (DECL_NAME (decl));
- }
-}
+ This function creates a binding context for the function body
+ as well as setting up the FUNCTION_DECL in current_function_decl.
-/* g77's function to print out name of current function that caused
- an error. */
+ Returns 1 on success. If the DECLARATOR is not suitable for a function
+ (it defines a datum instead), we return 0, which tells
+ yyparse to report a parse error.
-#if BUILT_FOR_270
-void
-lang_print_error_function (file)
- char *file;
+ NESTED is nonzero for a function nested within another function. */
+
+static void
+start_function (tree name, tree type, int nested, int public)
{
- static ffeglobal last_g = NULL;
- static ffesymbol last_s = NULL;
- ffeglobal g;
- ffesymbol s;
- const char *kind;
+ tree decl1;
+ tree restype;
+ int old_immediate_size_expand = immediate_size_expand;
- if ((ffecom_primary_entry_ == NULL)
- || (ffesymbol_global (ffecom_primary_entry_) == NULL))
+ named_labels = 0;
+ shadowed_labels = 0;
+
+ /* Don't expand any sizes in the return type of the function. */
+ immediate_size_expand = 0;
+
+ if (nested)
{
- g = NULL;
- s = NULL;
- kind = NULL;
+ 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
{
- g = ffesymbol_global (ffecom_primary_entry_);
- if (ffecom_nested_entry_ == NULL)
- {
- s = ffecom_primary_entry_;
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindFUNCTION:
- kind = "function";
- break;
+ 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;
- case FFEINFO_kindSUBROUTINE:
- kind = "subroutine";
- break;
+ announce_function (decl1);
- case FFEINFO_kindPROGRAM:
- kind = "program";
- break;
+ /* Make the init_value nonzero so pushdecl knows this is not tentative.
+ error_mark_node is replaced below (in poplevel) with the BLOCK. */
+ DECL_INITIAL (decl1) = error_mark_node;
- case FFEINFO_kindBLOCKDATA:
- kind = "block-data";
- break;
+ /* Record the decl so that the function name is defined. If we already have
+ a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
- default:
- kind = ffeinfo_kind_message (ffesymbol_kind (s));
- break;
- }
- }
- else
- {
- s = ffecom_nested_entry_;
- kind = "statement function";
- }
+ current_function_decl = pushdecl (decl1);
}
- if ((last_g != g) || (last_s != s))
- {
- if (file)
- fprintf (stderr, "%s: ", file);
+ if (!nested)
+ ffecom_outer_function_decl_ = current_function_decl;
- if (s == NULL)
- fprintf (stderr, "Outside of any program unit:\n");
- else
- {
- const char *name = ffesymbol_text (s);
+ pushlevel (0);
+ current_binding_level->prep_state = 2;
- fprintf (stderr, "In %s `%s':\n", kind, name);
- }
+ if (TREE_CODE (current_function_decl) != ERROR_MARK)
+ {
+ make_function_rtl (current_function_decl);
- last_g = g;
- last_s = s;
+ restype = TREE_TYPE (TREE_TYPE (current_function_decl));
+ DECL_RESULT (current_function_decl)
+ = build_decl (RESULT_DECL, NULL_TREE, restype);
}
-}
-#endif
-/* Similar to `lookup_name' but look only at current binding level. */
+ if (!nested)
+ /* Allocate further tree nodes temporarily during compilation of this
+ function only. */
+ temporary_allocation ();
-static tree
-lookup_name_current_level (tree name)
+ if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
+ TREE_ADDRESSABLE (current_function_decl) = 1;
+
+ immediate_size_expand = old_immediate_size_expand;
+}
+\f
+/* Here are the public functions the GNU back end needs. */
+
+tree
+convert (type, expr)
+ tree type, expr;
{
- register tree t;
+ register tree e = expr;
+ register enum tree_code code = TREE_CODE (type);
- if (current_binding_level == global_binding_level)
- return IDENTIFIER_GLOBAL_VALUE (name);
+ 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));
- if (IDENTIFIER_LOCAL_VALUE (name) == 0)
- return 0;
+ assert ("conversion to non-scalar type requested" == NULL);
+ return error_mark_node;
+}
- for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
- if (DECL_NAME (t) == name)
- break;
+/* integrate_decl_tree calls this function, but since we don't use the
+ DECL_LANG_SPECIFIC field, this is a no-op. */
- return t;
+void
+copy_lang_decl (node)
+ tree node UNUSED;
+{
}
-/* Create a new `struct binding_level'. */
+/* Return the list of declarations of the current level.
+ Note that this list is in reverse order unless/until
+ you nreverse it; and when you do nreverse it, you must
+ store the result back using `storedecls' or you will lose. */
-static struct binding_level *
-make_binding_level ()
+tree
+getdecls ()
{
- /* NOSTRICT */
- return (struct binding_level *) xmalloc (sizeof (struct binding_level));
+ return current_binding_level->names;
}
-/* Save and restore the variables in this file and elsewhere
- that keep track of the progress of compilation of the current function.
- Used for nested functions. */
+/* Nonzero if we are currently in the global binding level. */
-struct f_function
+int
+global_bindings_p ()
{
- struct f_function *next;
- tree named_labels;
- tree shadowed_labels;
- struct binding_level *binding_level;
-};
+ return current_binding_level == global_binding_level;
+}
-struct f_function *f_function_chain;
+/* Print an error message for invalid use of an incomplete type.
+ VALUE is the expression that was used (or 0 if that isn't known)
+ and TYPE is the type that was invalid. */
-/* Restore the variables used during compilation of a C function. */
+void
+incomplete_type_error (value, type)
+ tree value UNUSED;
+ tree type;
+{
+ if (TREE_CODE (type) == ERROR_MARK)
+ return;
-static void
-pop_f_function_context ()
+ assert ("incomplete type?!?" == NULL);
+}
+
+void
+init_decl_processing ()
{
- struct f_function *p = f_function_chain;
- tree link;
+ malloc_init ();
+ ffe_init_0 ();
+}
- /* Bring back all the labels that were shadowed. */
- for (link = shadowed_labels; link; link = TREE_CHAIN (link))
- if (DECL_NAME (TREE_VALUE (link)) != 0)
- IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
- = TREE_VALUE (link);
+char *
+init_parse (filename)
+ char *filename;
+{
+#if BUILT_FOR_270
+ extern void (*print_error_function) (char *);
+#endif
- if (current_function_decl != error_mark_node
- && DECL_SAVED_INSNS (current_function_decl) == 0)
+ /* Open input file. */
+ if (filename == 0 || !strcmp (filename, "-"))
{
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- DECL_INITIAL (current_function_decl) = error_mark_node;
- DECL_ARGUMENTS (current_function_decl) = 0;
+ finput = stdin;
+ filename = "stdin";
}
+ else
+ finput = fopen (filename, "r");
+ if (finput == 0)
+ pfatal_with_name (filename);
- pop_function_context ();
+#ifdef IO_BUFFER_SIZE
+ setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
+#endif
- f_function_chain = p->next;
+ /* Make identifier nodes long enough for the language-specific slots. */
+ set_identifier_size (sizeof (struct lang_identifier));
+ decl_printable_name = lang_printable_name;
+#if BUILT_FOR_270
+ print_error_function = lang_print_error_function;
+#endif
- named_labels = p->named_labels;
- shadowed_labels = p->shadowed_labels;
- current_binding_level = p->binding_level;
+ return filename;
+}
- free (p);
+void
+finish_parse ()
+{
+ fclose (finput);
+}
+
+/* Delete the node BLOCK from the current binding level.
+ This is used for the block inside a stmt expr ({...})
+ so that the block can be reinserted where appropriate. */
+
+static void
+delete_block (block)
+ tree block;
+{
+ tree t;
+ if (current_binding_level->blocks == block)
+ current_binding_level->blocks = TREE_CHAIN (block);
+ for (t = current_binding_level->blocks; t;)
+ {
+ if (TREE_CHAIN (t) == block)
+ TREE_CHAIN (t) = TREE_CHAIN (block);
+ else
+ t = TREE_CHAIN (t);
+ }
+ TREE_CHAIN (block) = NULL;
+ /* Clear TREE_USED which is always set by poplevel.
+ The flag is set again if insert_block is called. */
+ TREE_USED (block) = 0;
+}
+
+void
+insert_block (block)
+ tree block;
+{
+ TREE_USED (block) = 1;
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+}
+
+int
+lang_decode_option (argc, argv)
+ int argc;
+ char **argv;
+{
+ return ffe_decode_option (argc, argv);
}
-/* Save and reinitialize the variables
- used during compilation of a C function. */
+/* used by print-tree.c */
-static void
-push_f_function_context ()
+void
+lang_print_xnode (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
{
- struct f_function *p
- = (struct f_function *) xmalloc (sizeof (struct f_function));
-
- push_function_context ();
+}
- p->next = f_function_chain;
- f_function_chain = p;
+void
+lang_finish ()
+{
+ ffe_terminate_0 ();
- p->named_labels = named_labels;
- p->shadowed_labels = shadowed_labels;
- p->binding_level = current_binding_level;
+ if (ffe_is_ffedebug ())
+ malloc_pool_display (malloc_pool_image ());
}
-static void
-push_parm_decl (tree parm)
+char *
+lang_identify ()
{
- int old_immediate_size_expand = immediate_size_expand;
-
- /* Don't try computing parm sizes now -- wait till fn is called. */
+ return "f77";
+}
- immediate_size_expand = 0;
+void
+lang_init_options ()
+{
+ /* Set default options for Fortran. */
+ flag_move_all_movables = 1;
+ flag_reduce_all_givs = 1;
+ flag_argument_noalias = 2;
+}
- push_obstacks_nochange ();
+void
+lang_init ()
+{
+ /* If the file is output from cpp, it should contain a first line
+ `# 1 "real-filename"', and the current design of gcc (toplev.c
+ in particular and the way it sets up information relied on by
+ INCLUDE) requires that we read this now, and store the
+ "real-filename" info in master_input_filename. Ask the lexer
+ to try doing this. */
+ ffelex_hash_kludge (finput);
+}
- /* Fill in arg stuff. */
+int
+mark_addressable (exp)
+ tree exp;
+{
+ register tree x = exp;
+ while (1)
+ switch (TREE_CODE (x))
+ {
+ case ADDR_EXPR:
+ case COMPONENT_REF:
+ case ARRAY_REF:
+ x = TREE_OPERAND (x, 0);
+ break;
- DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
- DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
- TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (x) = 1;
+ return 1;
- parm = pushdecl (parm);
+ case VAR_DECL:
+ case CONST_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
+ && DECL_NONLOCAL (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ assert ("address of global register var requested" == NULL);
+ return 0;
+ }
+ assert ("address of register variable requested" == NULL);
+ }
+ else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ assert ("address of global register var requested" == NULL);
+ return 0;
+ }
+ assert ("address of register var requested" == NULL);
+ }
+ put_var_into_stack (x);
- immediate_size_expand = old_immediate_size_expand;
+ /* drops in */
+ case FUNCTION_DECL:
+ TREE_ADDRESSABLE (x) = 1;
+#if 0 /* poplevel deals with this now. */
+ if (DECL_CONTEXT (x) == 0)
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
+#endif
- finish_decl (parm, NULL_TREE, FALSE);
+ default:
+ return 1;
+ }
}
-/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
+/* If DECL has a cleanup, build and return that cleanup here.
+ This is a callback called by expand_expr. */
-static tree
-pushdecl_top_level (x)
- tree x;
+tree
+maybe_build_cleanup (decl)
+ tree decl UNUSED;
{
- register tree t;
- register struct binding_level *b = current_binding_level;
- register tree f = current_function_decl;
-
- current_binding_level = global_binding_level;
- current_function_decl = NULL_TREE;
- t = pushdecl (x);
- current_binding_level = b;
- current_function_decl = f;
- return t;
+ /* There are no cleanups in Fortran. */
+ return NULL_TREE;
}
-/* Store the list of declarations of the current level.
- This is done for the parameter declarations of a function being defined,
- after they are modified in the light of any missing parameters. */
+/* Exit a binding level.
+ Pop the level off, and restore the state of the identifier-decl mappings
+ that were in effect when this level was entered.
-static tree
-storedecls (decls)
- tree decls;
-{
- return current_binding_level->names = decls;
-}
+ If KEEP is nonzero, this level had explicit declarations, so
+ and create a "block" (a BLOCK node) for the level
+ to record its declarations and subblocks for symbol table output.
-/* Store the parameter declarations into the current function declaration.
- This is called after parsing the parameter declarations, before
- digesting the body of the function.
+ If FUNCTIONBODY is nonzero, this level is the body of a function,
+ so create a block as if KEEP were set and also clear out all
+ label names.
- For an old-style definition, modify the function's type
- to specify at least the number of arguments. */
+ If REVERSE is nonzero, reverse the order of decls before putting
+ them into the BLOCK. */
-static void
-store_parm_decls (int is_main_program UNUSED)
+tree
+poplevel (keep, reverse, functionbody)
+ int keep;
+ int reverse;
+ int functionbody;
{
- register tree fndecl = current_function_decl;
+ register tree link;
+ /* The chain of decls was accumulated in reverse order.
+ Put it into forward order, just for cleanliness. */
+ tree decls;
+ tree subblocks = current_binding_level->blocks;
+ tree block = 0;
+ tree decl;
+ int block_previously_created;
- if (fndecl == error_mark_node)
- return;
+ /* Get the decls in the order they were written.
+ Usually current_binding_level->names is in reverse order.
+ But parameter decls were previously put in forward order. */
- /* This is a chain of PARM_DECLs from old-style parm declarations. */
- DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
+ if (reverse)
+ current_binding_level->names
+ = decls = nreverse (current_binding_level->names);
+ else
+ decls = current_binding_level->names;
- /* Initialize the RTL code for the function. */
+ /* Output any nested inline functions within this block
+ if they weren't already output. */
- init_function_start (fndecl, input_filename, lineno);
+ for (decl = decls; decl; decl = TREE_CHAIN (decl))
+ if (TREE_CODE (decl) == FUNCTION_DECL
+ && ! TREE_ASM_WRITTEN (decl)
+ && DECL_INITIAL (decl) != 0
+ && TREE_ADDRESSABLE (decl))
+ {
+ /* If this decl was copied from a file-scope decl
+ on account of a block-scope extern decl,
+ propagate TREE_ADDRESSABLE to the file-scope decl.
+
+ DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
+ true, since then the decl goes through save_for_inline_copying. */
+ if (DECL_ABSTRACT_ORIGIN (decl) != 0
+ && DECL_ABSTRACT_ORIGIN (decl) != decl)
+ TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
+ else if (DECL_SAVED_INSNS (decl) != 0)
+ {
+ push_function_context ();
+ output_inline_function (decl);
+ pop_function_context ();
+ }
+ }
- /* Set up parameters and prepare for return, for the function. */
+ /* If there were any declarations or structure tags in that level,
+ or if this level is a function body,
+ create a BLOCK to record them for the life of this function. */
- expand_function_start (fndecl, 0);
-}
+ block = 0;
+ block_previously_created = (current_binding_level->this_block != 0);
+ if (block_previously_created)
+ block = current_binding_level->this_block;
+ else if (keep || functionbody)
+ block = make_node (BLOCK);
+ if (block != 0)
+ {
+ BLOCK_VARS (block) = decls;
+ BLOCK_SUBBLOCKS (block) = subblocks;
+ remember_end_note (block);
+ }
-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;
+ /* In each subblock, record that this is its superior. */
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
+ for (link = subblocks; link; link = TREE_CHAIN (link))
+ BLOCK_SUPERCONTEXT (link) = block;
- /* The corresponding pop_obstacks is in finish_decl. */
- push_obstacks_nochange ();
+ /* Clear out the meanings of the local variables of this level. */
- if (DECL_INITIAL (decl) != NULL_TREE)
+ for (link = decls; link; link = TREE_CHAIN (link))
{
- assert (DECL_INITIAL (decl) == error_mark_node);
- assert (!DECL_EXTERNAL (decl));
+ if (DECL_NAME (link) != 0)
+ {
+ /* If the ident. was used or addressed via a local extern decl,
+ don't forget that fact. */
+ if (DECL_EXTERNAL (link))
+ {
+ if (TREE_USED (link))
+ TREE_USED (DECL_NAME (link)) = 1;
+ if (TREE_ADDRESSABLE (link))
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
+ }
+ IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
+ }
}
- else if (top_level)
- assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
-
- /* For Fortran, we by default put things in .common when possible. */
- DECL_COMMON (decl) = 1;
- /* Add this decl to the current binding level. TEM may equal DECL or it may
- be a previous decl of the same name. */
- if (is_top_level)
- tem = pushdecl_top_level (decl);
- else
- tem = pushdecl (decl);
+ /* If the level being exited is the top level of a function,
+ check over all the labels, and clear out the current
+ (function local) meanings of their names. */
- /* For a local variable, define the RTL now. */
- if (!top_level
- /* But not if this is a duplicate decl and we preserved the rtl from the
- previous one (which may or may not happen). */
- && DECL_RTL (tem) == 0)
+ if (functionbody)
{
- if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
- expand_decl (tem);
- else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
- && DECL_INITIAL (tem) != 0)
- expand_decl (tem);
+ /* If this is the top level block of a function,
+ the vars are the function's parameters.
+ Don't leave them in the BLOCK because they are
+ found in the FUNCTION_DECL instead. */
+
+ BLOCK_VARS (block) = 0;
}
- if (DECL_INITIAL (tem) != NULL_TREE)
+ /* Pop the current level, and free the structure for reuse. */
+
+ {
+ register struct binding_level *level = current_binding_level;
+ current_binding_level = current_binding_level->level_chain;
+
+ level->level_chain = free_binding_level;
+ free_binding_level = level;
+ }
+
+ /* Dispose of the block that we just made inside some higher level. */
+ if (functionbody
+ && current_function_decl != error_mark_node)
+ DECL_INITIAL (current_function_decl) = block;
+ else if (block)
{
- /* When parsing and digesting the initializer, use temporary storage.
- Do this even if we will ignore the value. */
- if (at_top_level)
- temporary_allocation ();
+ if (!block_previously_created)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
}
+ /* If we did not make a block for the level just exited,
+ any blocks made for inner levels
+ (since they cannot be recorded as subblocks in that level)
+ must be carried forward so they will later become subblocks
+ of something else. */
+ else if (subblocks)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, subblocks);
- return tem;
+ if (block)
+ TREE_USED (block) = 1;
+ return block;
}
-/* Create the FUNCTION_DECL for a function definition.
- DECLSPECS and DECLARATOR are the parts of the declaration;
- they describe the function's name and the type it returns,
- but twisted together in a fashion that parallels the syntax of C.
-
- This function creates a binding context for the function body
- as well as setting up the FUNCTION_DECL in current_function_decl.
+void
+print_lang_decl (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
+{
+}
- Returns 1 on success. If the DECLARATOR is not suitable for a function
- (it defines a datum instead), we return 0, which tells
- yyparse to report a parse error.
+void
+print_lang_identifier (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
+{
+ print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
+ print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
+}
- NESTED is nonzero for a function nested within another function. */
+void
+print_lang_statistics ()
+{
+}
-static void
-start_function (tree name, tree type, int nested, int public)
+void
+print_lang_type (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
{
- tree decl1;
- tree restype;
- int old_immediate_size_expand = immediate_size_expand;
+}
- named_labels = 0;
- shadowed_labels = 0;
+/* Record a decl-node X as belonging to the current lexical scope.
+ Check for errors (such as an incompatible declaration for the same
+ name already seen in the same scope).
- /* Don't expand any sizes in the return type of the function. */
- immediate_size_expand = 0;
+ Returns either X or an old decl for the same name.
+ If an old decl is returned, it may have been smashed
+ to agree with what X says. */
- 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);
- }
+tree
+pushdecl (x)
+ tree x;
+{
+ register tree t;
+ register tree name = DECL_NAME (x);
+ register struct binding_level *b = current_binding_level;
- if (TREE_CODE (type) == ERROR_MARK)
- decl1 = current_function_decl = error_mark_node;
+ 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)
{
- 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;
+ if (IDENTIFIER_INVENTED (name))
+ {
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (x) = 1;
+#endif
+ DECL_IN_SYSTEM_HEADER (x) = 1;
+ }
- announce_function (decl1);
+ t = lookup_name_current_level (name);
- /* Make the init_value nonzero so pushdecl knows this is not tentative.
- error_mark_node is replaced below (in poplevel) with the BLOCK. */
- DECL_INITIAL (decl1) = error_mark_node;
+ assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
- /* Record the decl so that the function name is defined. If we already have
- a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
+ /* Don't push non-parms onto list for parms until we understand
+ why we're doing this and whether it works. */
- current_function_decl = pushdecl (decl1);
- }
+ assert ((b == global_binding_level)
+ || !ffecom_transform_only_dummies_
+ || TREE_CODE (x) == PARM_DECL);
- if (!nested)
- ffecom_outer_function_decl_ = current_function_decl;
+ if ((t != NULL_TREE) && duplicate_decls (x, t))
+ return t;
- pushlevel (0);
+ /* If we are processing a typedef statement, generate a whole new
+ ..._TYPE node (which will be just an variant of the existing
+ ..._TYPE node with identical properties) and then install the
+ TYPE_DECL node generated to represent the typedef name as the
+ TYPE_NAME of this brand new (duplicate) ..._TYPE node.
- if (TREE_CODE (current_function_decl) != ERROR_MARK)
- {
- make_function_rtl (current_function_decl);
+ The whole point here is to end up with a situation where each and every
+ ..._TYPE node the compiler creates will be uniquely associated with
+ AT MOST one node representing a typedef name. This way, even though
+ the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
+ (i.e. "typedef name") nodes very early on, later parts of the
+ compiler can always do the reverse translation and get back the
+ corresponding typedef name. For example, given:
- restype = TREE_TYPE (TREE_TYPE (current_function_decl));
- DECL_RESULT (current_function_decl)
- = build_decl (RESULT_DECL, NULL_TREE, restype);
- }
+ typedef struct S MY_TYPE; MY_TYPE object;
- if (!nested)
- /* Allocate further tree nodes temporarily during compilation of this
- function only. */
- temporary_allocation ();
+ Later parts of the compiler might only know that `object' was of type
+ `struct S' if it were not for code just below. With this code
+ however, later parts of the compiler see something like:
- if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
- TREE_ADDRESSABLE (current_function_decl) = 1;
+ struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
- immediate_size_expand = old_immediate_size_expand;
-}
-\f
-/* Here are the public functions the GNU back end needs. */
+ And they can then deduce (from the node for type struct S') that the
+ original object declaration was:
-tree
-convert (type, expr)
- tree type, expr;
-{
- register tree e = expr;
- register enum tree_code code = TREE_CODE (type);
+ MY_TYPE object;
- 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));
+ Being able to do this is important for proper support of protoize, and
+ also for generating precise symbolic debugging information which
+ takes full account of the programmer's (typedef) vocabulary.
- assert ("conversion to non-scalar type requested" == NULL);
- return error_mark_node;
-}
+ Obviously, we don't want to generate a duplicate ..._TYPE node if the
+ TYPE_DECL node that we are now processing really represents a
+ standard built-in type.
-/* integrate_decl_tree calls this function, but since we don't use the
- DECL_LANG_SPECIFIC field, this is a no-op. */
+ Since all standard types are effectively declared at line zero in the
+ source file, we can easily check to see if we are working on a
+ standard type by checking the current value of lineno. */
+
+ if (TREE_CODE (x) == TYPE_DECL)
+ {
+ if (DECL_SOURCE_LINE (x) == 0)
+ {
+ if (TYPE_NAME (TREE_TYPE (x)) == 0)
+ TYPE_NAME (TREE_TYPE (x)) = x;
+ }
+ else if (TREE_TYPE (x) != error_mark_node)
+ {
+ tree tt = TREE_TYPE (x);
+
+ tt = build_type_copy (tt);
+ TYPE_NAME (tt) = x;
+ TREE_TYPE (x) = tt;
+ }
+ }
-void
-copy_lang_decl (node)
- tree node UNUSED;
-{
-}
+ /* This name is new in its binding level. Install the new declaration
+ and return it. */
+ if (b == global_binding_level)
+ IDENTIFIER_GLOBAL_VALUE (name) = x;
+ else
+ IDENTIFIER_LOCAL_VALUE (name) = x;
+ }
-/* Return the list of declarations of the current level.
- Note that this list is in reverse order unless/until
- you nreverse it; and when you do nreverse it, you must
- store the result back using `storedecls' or you will lose. */
+ /* Put decls on list in reverse order. We will reverse them later if
+ necessary. */
+ TREE_CHAIN (x) = b->names;
+ b->names = x;
-tree
-getdecls ()
-{
- return current_binding_level->names;
+ return x;
}
-/* Nonzero if we are currently in the global binding level. */
+/* Nonzero if the current level needs to have a BLOCK made. */
-int
-global_bindings_p ()
+static int
+kept_level_p ()
{
- return current_binding_level == global_binding_level;
+ tree decl;
+
+ for (decl = current_binding_level->names;
+ decl;
+ decl = TREE_CHAIN (decl))
+ {
+ if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
+ || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
+ /* Currently, there aren't supposed to be non-artificial names
+ at other than the top block for a function -- they're
+ believed to always be temps. But it's wise to check anyway. */
+ return 1;
+ }
+ return 0;
}
-/* Insert BLOCK at the end of the list of subblocks of the
- current binding level. This is used when a BIND_EXPR is expanded,
- to handle the BLOCK node inside the BIND_EXPR. */
+/* Enter a new binding level.
+ If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
+ not for that of tags. */
void
-incomplete_type_error (value, type)
- tree value UNUSED;
- tree type;
+pushlevel (tag_transparent)
+ int tag_transparent;
{
- if (TREE_CODE (type) == ERROR_MARK)
- return;
+ register struct binding_level *newlevel = NULL_BINDING_LEVEL;
- assert ("incomplete type?!?" == NULL);
-}
+ assert (! tag_transparent);
-void
-init_decl_processing ()
-{
- malloc_init ();
- ffe_init_0 ();
-}
+ if (current_binding_level == global_binding_level)
+ {
+ named_labels = 0;
+ }
-char *
-init_parse (filename)
- char *filename;
-{
-#if BUILT_FOR_270
- extern void (*print_error_function) (char *);
-#endif
+ /* Reuse or create a struct for this binding level. */
- /* Open input file. */
- if (filename == 0 || !strcmp (filename, "-"))
+ if (free_binding_level)
{
- finput = stdin;
- filename = "stdin";
+ newlevel = free_binding_level;
+ free_binding_level = free_binding_level->level_chain;
}
else
- finput = fopen (filename, "r");
- if (finput == 0)
- pfatal_with_name (filename);
-
-#ifdef IO_BUFFER_SIZE
- setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
-#endif
+ {
+ newlevel = make_binding_level ();
+ }
- /* Make identifier nodes long enough for the language-specific slots. */
- set_identifier_size (sizeof (struct lang_identifier));
- decl_printable_name = lang_printable_name;
-#if BUILT_FOR_270
- print_error_function = lang_print_error_function;
-#endif
+ /* Add this level to the front of the chain (stack) of levels that
+ are active. */
- return filename;
+ *newlevel = clear_binding_level;
+ newlevel->level_chain = current_binding_level;
+ current_binding_level = newlevel;
}
-void
-finish_parse ()
-{
- fclose (finput);
-}
+/* Set the BLOCK node for the innermost scope
+ (the one we are currently in). */
void
-insert_block (block)
- tree block;
+set_block (block)
+ register tree block;
{
- TREE_USED (block) = 1;
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
+ current_binding_level->this_block = block;
}
-int
-lang_decode_option (argc, argv)
- int argc;
- char **argv;
-{
- return ffe_decode_option (argc, argv);
-}
+/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
-/* used by print-tree.c */
+/* Can't 'yydebug' a front end not generated by yacc/bison! */
void
-lang_print_xnode (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
+set_yydebug (value)
+ int value;
{
+ if (value)
+ fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
}
-void
-lang_finish ()
+tree
+signed_or_unsigned_type (unsignedp, type)
+ int unsignedp;
+ tree type;
{
- ffe_terminate_0 ();
-
- if (ffe_is_ffedebug ())
- malloc_pool_display (malloc_pool_image ());
-}
+ tree type2;
-char *
-lang_identify ()
-{
- return "f77";
-}
+ 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);
-void
-lang_init_options ()
-{
- /* Set default options for Fortran. */
- flag_move_all_movables = 1;
- flag_reduce_all_givs = 1;
- flag_argument_noalias = 2;
-}
+ type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
+ if (type2 == NULL_TREE)
+ return type;
-void
-lang_init ()
-{
- /* If the file is output from cpp, it should contain a first line
- `# 1 "real-filename"', and the current design of gcc (toplev.c
- in particular and the way it sets up information relied on by
- INCLUDE) requires that we read this now, and store the
- "real-filename" info in master_input_filename. Ask the lexer
- to try doing this. */
- ffelex_hash_kludge (finput);
+ return type2;
}
-int
-mark_addressable (exp)
- tree exp;
+tree
+signed_type (type)
+ tree type;
{
- 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;
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ ffeinfoKindtype kt;
+ tree type2;
- case CONSTRUCTOR:
- TREE_ADDRESSABLE (x) = 1;
- return 1;
+ if (type1 == unsigned_char_type_node || type1 == char_type_node)
+ return signed_char_type_node;
+ if (type1 == unsigned_type_node)
+ return integer_type_node;
+ if (type1 == short_unsigned_type_node)
+ return short_integer_type_node;
+ if (type1 == long_unsigned_type_node)
+ return long_integer_type_node;
+ if (type1 == long_long_unsigned_type_node)
+ return long_long_integer_type_node;
+#if 0 /* gcc/c-* files only */
+ if (type1 == unsigned_intDI_type_node)
+ return intDI_type_node;
+ if (type1 == unsigned_intSI_type_node)
+ return intSI_type_node;
+ if (type1 == unsigned_intHI_type_node)
+ return intHI_type_node;
+ if (type1 == unsigned_intQI_type_node)
+ return intQI_type_node;
+#endif
- case VAR_DECL:
- case CONST_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
- && DECL_NONLOCAL (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return 0;
- }
- assert ("address of register variable requested" == NULL);
- }
- else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return 0;
- }
- assert ("address of register var requested" == NULL);
- }
- put_var_into_stack (x);
+ type2 = type_for_size (TYPE_PRECISION (type1), 0);
+ if (type2 != NULL_TREE)
+ return type2;
- /* drops in */
- case FUNCTION_DECL:
- TREE_ADDRESSABLE (x) = 1;
-#if 0 /* poplevel deals with this now. */
- if (DECL_CONTEXT (x) == 0)
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
-#endif
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ {
+ type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
- default:
- return 1;
- }
+ if (type1 == type2)
+ return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ }
+
+ return type;
}
-/* If DECL has a cleanup, build and return that cleanup here.
- This is a callback called by expand_expr. */
+/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
+ or validate its data type for an `if' or `while' statement or ?..: exp.
+
+ This preparation consists of taking the ordinary
+ representation of an expression expr and producing a valid tree
+ boolean expression describing whether expr is nonzero. We could
+ simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
+ but we optimize comparisons, &&, ||, and !.
+
+ The resulting type should always be `integer_type_node'. */
tree
-maybe_build_cleanup (decl)
- tree decl UNUSED;
+truthvalue_conversion (expr)
+ tree expr;
{
- /* There are no cleanups in Fortran. */
- return NULL_TREE;
-}
+ if (TREE_CODE (expr) == ERROR_MARK)
+ return expr;
-/* Exit a binding level.
- Pop the level off, and restore the state of the identifier-decl mappings
- that were in effect when this level was entered.
+#if 0 /* This appears to be wrong for C++. */
+ /* These really should return error_mark_node after 2.4 is stable.
+ But not all callers handle ERROR_MARK properly. */
+ switch (TREE_CODE (TREE_TYPE (expr)))
+ {
+ case RECORD_TYPE:
+ error ("struct type value used where scalar is required");
+ return integer_zero_node;
- If KEEP is nonzero, this level had explicit declarations, so
- and create a "block" (a BLOCK node) for the level
- to record its declarations and subblocks for symbol table output.
+ case UNION_TYPE:
+ error ("union type value used where scalar is required");
+ return integer_zero_node;
- If FUNCTIONBODY is nonzero, this level is the body of a function,
- so create a block as if KEEP were set and also clear out all
- label names.
+ case ARRAY_TYPE:
+ error ("array type value used where scalar is required");
+ return integer_zero_node;
- If REVERSE is nonzero, reverse the order of decls before putting
- them into the BLOCK. */
+ default:
+ break;
+ }
+#endif /* 0 */
-tree
-poplevel (keep, reverse, functionbody)
- int keep;
- int reverse;
- int functionbody;
-{
- register tree link;
- /* The chain of decls was accumulated in reverse order. Put it into forward
- order, just for cleanliness. */
- tree decls;
- tree subblocks = current_binding_level->blocks;
- tree block = 0;
- tree decl;
- int block_previously_created;
+ switch (TREE_CODE (expr))
+ {
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+#if 0
+ case COMPONENT_REF:
+ /* A one-bit unsigned bit-field is already acceptable. */
+ if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
+ && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
+ return expr;
+ break;
+#endif
+
+ case EQ_EXPR:
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+#if 0
+ if (integer_zerop (TREE_OPERAND (expr, 1)))
+ return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
+#endif
+ case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ TREE_TYPE (expr) = integer_type_node;
+ return expr;
- /* Get the decls in the order they were written. Usually
- current_binding_level->names is in reverse order. But parameter decls
- were previously put in forward order. */
+ case ERROR_MARK:
+ return expr;
- if (reverse)
- current_binding_level->names
- = decls = nreverse (current_binding_level->names);
- else
- decls = current_binding_level->names;
+ case INTEGER_CST:
+ return integer_zerop (expr) ? integer_zero_node : integer_one_node;
- /* Output any nested inline functions within this block if they weren't
- already output. */
+ case REAL_CST:
+ return real_zerop (expr) ? integer_zero_node : integer_one_node;
- for (decl = decls; decl; decl = TREE_CHAIN (decl))
- if (TREE_CODE (decl) == FUNCTION_DECL
- && !TREE_ASM_WRITTEN (decl)
- && DECL_INITIAL (decl) != 0
- && TREE_ADDRESSABLE (decl))
- {
- /* If this decl was copied from a file-scope decl on account of a
- block-scope extern decl, propagate TREE_ADDRESSABLE to the
- file-scope decl. */
- if (DECL_ABSTRACT_ORIGIN (decl) != 0)
- TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
- else
- {
- push_function_context ();
- output_inline_function (decl);
- pop_function_context ();
- }
- }
+ 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;
- /* If there were any declarations or structure tags in that level, or if
- this level is a function body, create a BLOCK to record them for the
- life of this function. */
+ case COMPLEX_EXPR:
+ return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
+ ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
+ integer_type_node,
+ truthvalue_conversion (TREE_OPERAND (expr, 0)),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)));
- block = 0;
- block_previously_created = (current_binding_level->this_block != 0);
- if (block_previously_created)
- block = current_binding_level->this_block;
- else if (keep || functionbody)
- block = make_node (BLOCK);
- if (block != 0)
- {
- BLOCK_VARS (block) = decls;
- BLOCK_SUBBLOCKS (block) = subblocks;
- remember_end_note (block);
- }
+ case NEGATE_EXPR:
+ case ABS_EXPR:
+ case FLOAT_EXPR:
+ case FFS_EXPR:
+ /* These don't change whether an object is non-zero or zero. */
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
- /* In each subblock, record that this is its superior. */
+ case LROTATE_EXPR:
+ case RROTATE_EXPR:
+ /* These don't change whether an object is zero or non-zero, but
+ we can't ignore them if their second arg has side-effects. */
+ if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
+ return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
+ truthvalue_conversion (TREE_OPERAND (expr, 0)));
+ else
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
- for (link = subblocks; link; link = TREE_CHAIN (link))
- BLOCK_SUPERCONTEXT (link) = block;
+ case COND_EXPR:
+ /* Distribute the conversion into the arms of a COND_EXPR. */
+ return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ truthvalue_conversion (TREE_OPERAND (expr, 2))));
- /* Clear out the meanings of the local variables of this level. */
+ case CONVERT_EXPR:
+ /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
+ since that affects how `default_conversion' will behave. */
+ if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
+ || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
+ break;
+ /* fall through... */
+ case NOP_EXPR:
+ /* If this is widening the argument, we can ignore it. */
+ if (TYPE_PRECISION (TREE_TYPE (expr))
+ >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ break;
- for (link = decls; link; link = TREE_CHAIN (link))
- {
- if (DECL_NAME (link) != 0)
- {
- /* If the ident. was used or addressed via a local extern decl,
- don't forget that fact. */
- if (DECL_EXTERNAL (link))
- {
- if (TREE_USED (link))
- TREE_USED (DECL_NAME (link)) = 1;
- if (TREE_ADDRESSABLE (link))
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
- }
- IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
- }
+ case MINUS_EXPR:
+ /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
+ this case. */
+ if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
+ && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
+ break;
+ /* fall through... */
+ case BIT_XOR_EXPR:
+ /* This and MINUS_EXPR can be changed into a comparison of the
+ two objects. */
+ if (TREE_TYPE (TREE_OPERAND (expr, 0))
+ == TREE_TYPE (TREE_OPERAND (expr, 1)))
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0),
+ TREE_OPERAND (expr, 1));
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0),
+ fold (build1 (NOP_EXPR,
+ TREE_TYPE (TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1))));
+
+ case BIT_AND_EXPR:
+ if (integer_onep (TREE_OPERAND (expr, 1)))
+ return expr;
+ break;
+
+ case MODIFY_EXPR:
+#if 0 /* No such thing in Fortran. */
+ if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
+ warning ("suggest parentheses around assignment used as truth value");
+#endif
+ break;
+
+ default:
+ break;
}
- /* If the level being exited is the top level of a function, check over all
- the labels, and clear out the current (function local) meanings of their
- names. */
+ if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
+ return (ffecom_2
+ ((TREE_SIDE_EFFECTS (expr)
+ ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
+ integer_type_node,
+ truthvalue_conversion (ffecom_1 (REALPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr)),
+ truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr))));
+
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ expr,
+ convert (TREE_TYPE (expr), integer_zero_node));
+}
+
+tree
+type_for_mode (mode, unsignedp)
+ enum machine_mode mode;
+ int unsignedp;
+{
+ int i;
+ int j;
+ tree t;
- if (functionbody)
- {
- /* If this is the top level block of a function, the vars are the
- function's parameters. Don't leave them in the BLOCK because they
- are found in the FUNCTION_DECL instead. */
+ if (mode == TYPE_MODE (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
- BLOCK_VARS (block) = 0;
- }
+ if (mode == TYPE_MODE (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- /* Pop the current level, and free the structure for reuse. */
+ if (mode == TYPE_MODE (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- {
- register struct binding_level *level = current_binding_level;
- current_binding_level = current_binding_level->level_chain;
+ if (mode == TYPE_MODE (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- level->level_chain = free_binding_level;
- free_binding_level = level;
- }
+ if (mode == TYPE_MODE (long_long_integer_type_node))
+ return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
- /* Dispose of the block that we just made inside some higher level. */
- if (functionbody
- && current_function_decl != error_mark_node)
- DECL_INITIAL (current_function_decl) = block;
- else if (block)
- {
- if (!block_previously_created)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
- }
- /* If we did not make a block for the level just exited, any blocks made
- for inner levels (since they cannot be recorded as subblocks in that
- level) must be carried forward so they will later become subblocks of
- something else. */
- else if (subblocks)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, subblocks);
+ if (mode == TYPE_MODE (float_type_node))
+ return float_type_node;
- /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
- binding contour so that they point to the appropriate construct, i.e.
- either to the current FUNCTION_DECL node, or else to the BLOCK node we
- just constructed.
+ if (mode == TYPE_MODE (double_type_node))
+ return double_type_node;
- Note that for tagged types whose scope is just the formal parameter list
- for some function type specification, we can't properly set their
- TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
- FUNCTION_TYPE node readily available to us. For those cases, the
- TYPE_CONTEXTs of the relevant tagged type nodes get set in
- `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
- will represent the "scope" for these "parameter list local" tagged
- types. */
+ if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
+ return build_pointer_type (char_type_node);
- if (block)
- TREE_USED (block) = 1;
- return block;
-}
+ if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
+ return build_pointer_type (integer_type_node);
-void
-print_lang_decl (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
+ 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;
+ }
+ }
-void
-print_lang_identifier (file, node, indent)
- FILE *file;
- tree node;
- int indent;
-{
- print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
- print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
+ return 0;
}
-void
-print_lang_statistics ()
+tree
+type_for_size (bits, unsignedp)
+ unsigned bits;
+ int unsignedp;
{
-}
+ ffeinfoKindtype kt;
+ tree type_node;
-void
-print_lang_type (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
+ if (bits == TYPE_PRECISION (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
-/* Record a decl-node X as belonging to the current lexical scope.
- Check for errors (such as an incompatible declaration for the same
- name already seen in the same scope).
+ if (bits == TYPE_PRECISION (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- Returns either X or an old decl for the same name.
- If an old decl is returned, it may have been smashed
- to agree with what X says. */
+ if (bits == TYPE_PRECISION (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
-tree
-pushdecl (x)
- tree x;
-{
- register tree t;
- register tree name = DECL_NAME (x);
- register struct binding_level *b = current_binding_level;
+ if (bits == TYPE_PRECISION (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- 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 (bits == TYPE_PRECISION (long_long_integer_type_node))
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
- if (name)
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
{
- if (IDENTIFIER_INVENTED (name))
- {
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (x) = 1;
-#endif
- DECL_IN_SYSTEM_HEADER (x) = 1;
- }
-
- t = lookup_name_current_level (name);
-
- assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
+ type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
- /* Don't push non-parms onto list for parms until we understand
- why we're doing this and whether it works. */
+ if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
+ return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
+ : type_node;
+ }
- assert ((b == global_binding_level)
- || !ffecom_transform_only_dummies_
- || TREE_CODE (x) == PARM_DECL);
+ return 0;
+}
- if ((t != NULL_TREE) && duplicate_decls (x, t))
- return t;
+tree
+unsigned_type (type)
+ tree type;
+{
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ ffeinfoKindtype kt;
+ tree type2;
- /* If we are processing a typedef statement, generate a whole new
- ..._TYPE node (which will be just an variant of the existing
- ..._TYPE node with identical properties) and then install the
- TYPE_DECL node generated to represent the typedef name as the
- TYPE_NAME of this brand new (duplicate) ..._TYPE node.
+ if (type1 == signed_char_type_node || type1 == char_type_node)
+ return unsigned_char_type_node;
+ if (type1 == integer_type_node)
+ return unsigned_type_node;
+ if (type1 == short_integer_type_node)
+ return short_unsigned_type_node;
+ if (type1 == long_integer_type_node)
+ return long_unsigned_type_node;
+ if (type1 == long_long_integer_type_node)
+ return long_long_unsigned_type_node;
+#if 0 /* gcc/c-* files only */
+ if (type1 == intDI_type_node)
+ return unsigned_intDI_type_node;
+ if (type1 == intSI_type_node)
+ return unsigned_intSI_type_node;
+ if (type1 == intHI_type_node)
+ return unsigned_intHI_type_node;
+ if (type1 == intQI_type_node)
+ return unsigned_intQI_type_node;
+#endif
- The whole point here is to end up with a situation where each and every
- ..._TYPE node the compiler creates will be uniquely associated with
- AT MOST one node representing a typedef name. This way, even though
- the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
- (i.e. "typedef name") nodes very early on, later parts of the
- compiler can always do the reverse translation and get back the
- corresponding typedef name. For example, given:
+ type2 = type_for_size (TYPE_PRECISION (type1), 1);
+ if (type2 != NULL_TREE)
+ return type2;
- typedef struct S MY_TYPE; MY_TYPE object;
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ {
+ type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
- Later parts of the compiler might only know that `object' was of type
- `struct S' if it were not for code just below. With this code
- however, later parts of the compiler see something like:
+ if (type1 == type2)
+ return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+ }
- struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
+ return type;
+}
- And they can then deduce (from the node for type struct S') that the
- original object declaration was:
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
+\f
+#if FFECOM_GCC_INCLUDE
- MY_TYPE object;
+/* From gcc/cccp.c, the code to handle -I. */
- Being able to do this is important for proper support of protoize, and
- also for generating precise symbolic debugging information which
- takes full account of the programmer's (typedef) vocabulary.
+/* Skip leading "./" from a directory name.
+ This may yield the empty string, which represents the current directory. */
- Obviously, we don't want to generate a duplicate ..._TYPE node if the
- TYPE_DECL node that we are now processing really represents a
- standard built-in type.
+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;
+}
- Since all standard types are effectively declared at line zero in the
- source file, we can easily check to see if we are working on a
- standard type by checking the current value of lineno. */
+/* The file_name_map structure holds a mapping of file names for a
+ particular directory. This mapping is read from the file named
+ FILE_NAME_MAP_FILE in that directory. Such a file can be used to
+ map filenames on a file system with severe filename restrictions,
+ such as DOS. The format of the file name map file is just a series
+ of lines with two tokens on each line. The first token is the name
+ to map, and the second token is the actual name to use. */
- 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);
+struct file_name_map
+{
+ struct file_name_map *map_next;
+ char *map_from;
+ char *map_to;
+};
- tt = build_type_copy (tt);
- TYPE_NAME (tt) = x;
- TREE_TYPE (x) = tt;
- }
- }
+#define FILE_NAME_MAP_FILE "header.gcc"
- /* This name is new in its binding level. Install the new declaration
- and return it. */
- if (b == global_binding_level)
- IDENTIFIER_GLOBAL_VALUE (name) = x;
- else
- IDENTIFIER_LOCAL_VALUE (name) = x;
- }
+/* Current maximum length of directory names in the search path
+ for include files. (Altered as we get more of them.) */
- /* Put decls on list in reverse order. We will reverse them later if
- necessary. */
- TREE_CHAIN (x) = b->names;
- b->names = x;
+static int max_include_len = 0;
- return x;
-}
+struct file_name_list
+ {
+ struct file_name_list *next;
+ char *fname;
+ /* Mapping of file names for this directory. */
+ struct file_name_map *name_map;
+ /* Non-zero if name_map is valid. */
+ int got_name_map;
+ };
-/* Enter a new binding level.
- If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
- not for that of tags. */
+static struct file_name_list *include = NULL; /* First dir to search */
+static struct file_name_list *last_include = NULL; /* Last in chain */
-void
-pushlevel (tag_transparent)
- int tag_transparent;
-{
- register struct binding_level *newlevel = NULL_BINDING_LEVEL;
+/* I/O buffer structure.
+ The `fname' field is nonzero for source files and #include files
+ and for the dummy text used for -D and -U.
+ It is zero for rescanning results of macro expansion
+ and for expanding macro arguments. */
+#define INPUT_STACK_MAX 400
+static struct file_buf {
+ char *fname;
+ /* Filename specified with #line command. */
+ char *nominal_fname;
+ /* Record where in the search path this file was found.
+ For #include_next. */
+ struct file_name_list *dir;
+ ffewhereLine line;
+ ffewhereColumn column;
+} instack[INPUT_STACK_MAX];
- assert (!tag_transparent);
+static int last_error_tick = 0; /* Incremented each time we print it. */
+static int input_file_stack_tick = 0; /* Incremented when status changes. */
- /* Reuse or create a struct for this binding level. */
+/* Current nesting level of input sources.
+ `instack[indepth]' is the level currently being read. */
+static int indepth = -1;
- if (free_binding_level)
- {
- newlevel = free_binding_level;
- free_binding_level = free_binding_level->level_chain;
- }
- else
- {
- newlevel = make_binding_level ();
- }
+typedef struct file_buf FILE_BUF;
- /* Add this level to the front of the chain (stack) of levels that are
- active. */
+typedef unsigned char U_CHAR;
- *newlevel = clear_binding_level;
- newlevel->level_chain = current_binding_level;
- current_binding_level = newlevel;
-}
+/* table to tell if char can be part of a C identifier. */
+U_CHAR is_idchar[256];
+/* table to tell if char can be first char of a c identifier. */
+U_CHAR is_idstart[256];
+/* table to tell if c is horizontal space. */
+U_CHAR is_hor_space[256];
+/* table to tell if c is horizontal or vertical space. */
+static U_CHAR is_space[256];
-/* Set the BLOCK node for the innermost scope
- (the one we are currently in). */
+#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
+#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
-void
-set_block (block)
- register tree block;
-{
- current_binding_level->this_block = block;
-}
+/* Nonzero means -I- has been seen,
+ so don't look for #include "foo" the source-file directory. */
+static int ignore_srcdir;
-/* ~~tree.h SHOULD declare this, because toplev.c references it. */
+#ifndef INCLUDE_LEN_FUDGE
+#define INCLUDE_LEN_FUDGE 0
+#endif
-/* Can't 'yydebug' a front end not generated by yacc/bison! */
+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 const char *skip_redundant_dir_prefix (const char *);
+static char *read_filename_string (int ch, FILE *f);
+static struct file_name_map *read_name_map (const char *dirname);
-void
-set_yydebug (value)
- int value;
-{
- if (value)
- fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
-}
+/* Append a chain of `struct file_name_list's
+ to the end of the main include chain.
+ FIRST is the beginning of the chain to append, and LAST is the end. */
-tree
-signed_or_unsigned_type (unsignedp, type)
- int unsignedp;
- tree type;
+static void
+append_include_chain (first, last)
+ struct file_name_list *first, *last;
{
- tree type2;
+ struct file_name_list *dir;
- 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);
+ if (!first || !last)
+ return;
- type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
- if (type2 == NULL_TREE)
- return type;
+ if (include == 0)
+ include = first;
+ else
+ last_include->next = first;
- return type2;
+ 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;
}
-tree
-signed_type (type)
- tree type;
+/* Try to open include file FILENAME. SEARCHPTR is the directory
+ being tried from the include file search path. This function maps
+ filenames on file systems based on information read by
+ read_name_map. */
+
+static FILE *
+open_include_file (filename, searchptr)
+ char *filename;
+ struct file_name_list *searchptr;
{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
+ register struct file_name_map *map;
+ register char *from;
+ char *p, *dir;
- if (type1 == unsigned_char_type_node || type1 == char_type_node)
- return signed_char_type_node;
- if (type1 == unsigned_type_node)
- return integer_type_node;
- if (type1 == short_unsigned_type_node)
- return short_integer_type_node;
- if (type1 == long_unsigned_type_node)
- return long_integer_type_node;
- if (type1 == long_long_unsigned_type_node)
- return long_long_integer_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == unsigned_intDI_type_node)
- return intDI_type_node;
- if (type1 == unsigned_intSI_type_node)
- return intSI_type_node;
- if (type1 == unsigned_intHI_type_node)
- return intHI_type_node;
- if (type1 == unsigned_intQI_type_node)
- return intQI_type_node;
-#endif
+ if (searchptr && ! searchptr->got_name_map)
+ {
+ searchptr->name_map = read_name_map (searchptr->fname
+ ? searchptr->fname : ".");
+ searchptr->got_name_map = 1;
+ }
- type2 = type_for_size (TYPE_PRECISION (type1), 0);
- if (type2 != NULL_TREE)
- return type2;
+ /* First check the mapping for the directory we are using. */
+ if (searchptr && searchptr->name_map)
+ {
+ from = filename;
+ if (searchptr->fname)
+ from += strlen (searchptr->fname) + 1;
+ for (map = searchptr->name_map; map; map = map->map_next)
+ {
+ if (! strcmp (map->map_from, from))
+ {
+ /* Found a match. */
+ return fopen (map->map_to, "r");
+ }
+ }
+ }
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ /* Try to find a mapping file for the particular directory we are
+ looking in. Thus #include <sys/types.h> will look up sys/types.h
+ in /usr/include/header.gcc and look up types.h in
+ /usr/include/sys/header.gcc. */
+ p = rindex (filename, '/');
+#ifdef DIR_SEPARATOR
+ if (! p) p = rindex (filename, DIR_SEPARATOR);
+ else {
+ char *tmp = rindex (filename, DIR_SEPARATOR);
+ if (tmp != NULL && tmp > p) p = tmp;
+ }
+#endif
+ if (! p)
+ p = filename;
+ if (searchptr
+ && searchptr->fname
+ && strlen (searchptr->fname) == (size_t) (p - filename)
+ && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
+ {
+ /* FILENAME is in SEARCHPTR, which we've already checked. */
+ return fopen (filename, "r");
+ }
+
+ if (p == filename)
+ {
+ from = filename;
+ map = read_name_map (".");
+ }
+ else
{
- type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
-
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ 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 type;
+ return fopen (filename, "r");
}
-/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
- or validate its data type for an `if' or `while' statement or ?..: exp.
+/* Print the file names and line numbers of the #include
+ commands which led to the current file. */
- This preparation consists of taking the ordinary
- representation of an expression expr and producing a valid tree
- boolean expression describing whether expr is nonzero. We could
- simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
- but we optimize comparisons, &&, ||, and !.
+static void
+print_containing_files (ffebadSeverity sev)
+{
+ FILE_BUF *ip = NULL;
+ int i;
+ int first = 1;
+ const char *str1;
+ const char *str2;
- The resulting type should always be `integer_type_node'. */
+ /* If stack of files hasn't changed since we last printed
+ this info, don't repeat it. */
+ if (last_error_tick == input_file_stack_tick)
+ return;
-tree
-truthvalue_conversion (expr)
- tree expr;
-{
- if (TREE_CODE (expr) == ERROR_MARK)
- return expr;
+ for (i = indepth; i >= 0; i--)
+ if (instack[i].fname != NULL) {
+ ip = &instack[i];
+ break;
+ }
-#if 0 /* This appears to be wrong for C++. */
- /* These really should return error_mark_node after 2.4 is stable.
- But not all callers handle ERROR_MARK properly. */
- switch (TREE_CODE (TREE_TYPE (expr)))
- {
- case RECORD_TYPE:
- error ("struct type value used where scalar is required");
- return integer_zero_node;
+ /* Give up if we don't find a source file. */
+ if (ip == NULL)
+ return;
- case UNION_TYPE:
- error ("union type value used where scalar is required");
- return integer_zero_node;
+ /* Find the other, outer source files. */
+ for (i--; i >= 0; i--)
+ if (instack[i].fname != NULL)
+ {
+ ip = &instack[i];
+ if (first)
+ {
+ first = 0;
+ str1 = "In file included";
+ }
+ else
+ {
+ str1 = "... ...";
+ }
- case ARRAY_TYPE:
- error ("array type value used where scalar is required");
- return integer_zero_node;
+ if (i == 1)
+ str2 = ":";
+ else
+ str2 = "";
- default:
- break;
- }
-#endif /* 0 */
+ 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 ();
+ }
- switch (TREE_CODE (expr))
- {
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- case COMPONENT_REF:
- /* A one-bit unsigned bit-field is already acceptable. */
- if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
- && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
- return expr;
- break;
-#endif
+ /* Record we have printed the status as of this time. */
+ last_error_tick = input_file_stack_tick;
+}
- case EQ_EXPR:
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- if (integer_zerop (TREE_OPERAND (expr, 1)))
- return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
-#endif
- case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- TREE_TYPE (expr) = integer_type_node;
- return expr;
+/* Read a space delimited string of unlimited length from a stdio
+ file. */
- case ERROR_MARK:
- return expr;
+static char *
+read_filename_string (ch, f)
+ int ch;
+ FILE *f;
+{
+ char *alloc, *set;
+ int len;
- case INTEGER_CST:
- return integer_zerop (expr) ? integer_zero_node : integer_one_node;
+ len = 20;
+ set = alloc = xmalloc (len + 1);
+ if (! is_space[ch])
+ {
+ *set++ = ch;
+ while ((ch = getc (f)) != EOF && ! is_space[ch])
+ {
+ if (set - alloc == len)
+ {
+ len *= 2;
+ alloc = xrealloc (alloc, len + 1);
+ set = alloc + len / 2;
+ }
+ *set++ = ch;
+ }
+ }
+ *set = '\0';
+ ungetc (ch, f);
+ return alloc;
+}
- case REAL_CST:
- return real_zerop (expr) ? integer_zero_node : integer_one_node;
+/* Read the file name map file for DIRNAME. */
- 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;
+static struct file_name_map *
+read_name_map (dirname)
+ const char *dirname;
+{
+ /* This structure holds a linked list of file name maps, one per
+ directory. */
+ struct file_name_map_list
+ {
+ struct file_name_map_list *map_list_next;
+ char *map_list_name;
+ struct file_name_map *map_list_map;
+ };
+ static struct file_name_map_list *map_list;
+ register struct file_name_map_list *map_list_ptr;
+ char *name;
+ FILE *f;
+ size_t dirlen;
+ int separator_needed;
- case COMPLEX_EXPR:
- return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- truthvalue_conversion (TREE_OPERAND (expr, 0)),
- truthvalue_conversion (TREE_OPERAND (expr, 1)));
+ dirname = skip_redundant_dir_prefix (dirname);
- case NEGATE_EXPR:
- case ABS_EXPR:
- case FLOAT_EXPR:
- case FFS_EXPR:
- /* These don't change whether an object is non-zero or zero. */
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ 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;
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- /* These don't change whether an object is zero or non-zero, but
- we can't ignore them if their second arg has side-effects. */
- if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
- return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
- truthvalue_conversion (TREE_OPERAND (expr, 0)));
- else
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ 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;
- case COND_EXPR:
- /* Distribute the conversion into the arms of a COND_EXPR. */
- return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
- truthvalue_conversion (TREE_OPERAND (expr, 1)),
- truthvalue_conversion (TREE_OPERAND (expr, 2))));
+ dirlen = strlen (dirname);
+ separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
+ name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
+ strcpy (name, dirname);
+ name[dirlen] = '/';
+ strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
+ f = fopen (name, "r");
+ free (name);
+ if (!f)
+ map_list_ptr->map_list_map = NULL;
+ else
+ {
+ int ch;
- case CONVERT_EXPR:
- /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
- since that affects how `default_conversion' will behave. */
- if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
- || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
- break;
- /* fall through... */
- case NOP_EXPR:
- /* If this is widening the argument, we can ignore it. */
- if (TYPE_PRECISION (TREE_TYPE (expr))
- >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
- break;
+ while ((ch = getc (f)) != EOF)
+ {
+ char *from, *to;
+ struct file_name_map *ptr;
+
+ if (is_space[ch])
+ continue;
+ from = read_filename_string (ch, f);
+ while ((ch = getc (f)) != EOF && is_hor_space[ch])
+ ;
+ to = read_filename_string (ch, f);
- case MINUS_EXPR:
- /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
- this case. */
- if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
- && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
- break;
- /* fall through... */
- case BIT_XOR_EXPR:
- /* This and MINUS_EXPR can be changed into a comparison of the
- two objects. */
- if (TREE_TYPE (TREE_OPERAND (expr, 0))
- == TREE_TYPE (TREE_OPERAND (expr, 1)))
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- TREE_OPERAND (expr, 1));
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- fold (build1 (NOP_EXPR,
- TREE_TYPE (TREE_OPERAND (expr, 0)),
- TREE_OPERAND (expr, 1))));
+ ptr = ((struct file_name_map *)
+ xmalloc (sizeof (struct file_name_map)));
+ ptr->map_from = from;
- case BIT_AND_EXPR:
- if (integer_onep (TREE_OPERAND (expr, 1)))
- return expr;
- break;
+ /* Make the real filename absolute. */
+ if (*to == '/')
+ ptr->map_to = to;
+ else
+ {
+ ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
+ strcpy (ptr->map_to, dirname);
+ ptr->map_to[dirlen] = '/';
+ strcpy (ptr->map_to + dirlen + separator_needed, to);
+ free (to);
+ }
- case MODIFY_EXPR:
-#if 0 /* No such thing in Fortran. */
- if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
- warning ("suggest parentheses around assignment used as truth value");
-#endif
- break;
+ ptr->map_next = map_list_ptr->map_list_map;
+ map_list_ptr->map_list_map = ptr;
- default:
- break;
+ while ((ch = getc (f)) != '\n')
+ if (ch == EOF)
+ break;
+ }
+ fclose (f);
}
- if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
- return (ffecom_2
- ((TREE_SIDE_EFFECTS (expr)
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- truthvalue_conversion (ffecom_1 (REALPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr)),
- truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr))));
+ map_list_ptr->map_list_next = map_list;
+ map_list = map_list_ptr;
- return ffecom_2 (NE_EXPR, integer_type_node,
- expr,
- convert (TREE_TYPE (expr), integer_zero_node));
+ return map_list_ptr->map_list_map;
}
-tree
-type_for_mode (mode, unsignedp)
- enum machine_mode mode;
- int unsignedp;
+static void
+ffecom_file_ (char *name)
{
- int i;
- int j;
- tree t;
+ FILE_BUF *fp;
- if (mode == TYPE_MODE (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
+ /* Do partial setup of input buffer for the sake of generating
+ early #line directives (when -g is in effect). */
- if (mode == TYPE_MODE (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ fp = &instack[++indepth];
+ memset ((char *) fp, 0, sizeof (FILE_BUF));
+ if (name == NULL)
+ name = "";
+ fp->nominal_fname = fp->fname = name;
+}
- if (mode == TYPE_MODE (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+/* Initialize syntactic classifications of characters. */
- if (mode == TYPE_MODE (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+static void
+ffecom_initialize_char_syntax_ ()
+{
+ register int i;
- if (mode == TYPE_MODE (long_long_integer_type_node))
- return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
+ /*
+ * Set up is_idchar and is_idstart tables. These should be
+ * faster than saying (is_alpha (c) || c == '_'), etc.
+ * Set up these things before calling any routines tthat
+ * refer to them.
+ */
+ for (i = 'a'; i <= 'z'; i++) {
+ is_idchar[i - 'a' + 'A'] = 1;
+ is_idchar[i] = 1;
+ is_idstart[i - 'a' + 'A'] = 1;
+ is_idstart[i] = 1;
+ }
+ for (i = '0'; i <= '9'; i++)
+ is_idchar[i] = 1;
+ is_idchar['_'] = 1;
+ is_idstart['_'] = 1;
- if (mode == TYPE_MODE (float_type_node))
- return float_type_node;
+ /* horizontal space table */
+ is_hor_space[' '] = 1;
+ is_hor_space['\t'] = 1;
+ is_hor_space['\v'] = 1;
+ is_hor_space['\f'] = 1;
+ is_hor_space['\r'] = 1;
- if (mode == TYPE_MODE (double_type_node))
- return double_type_node;
+ is_space[' '] = 1;
+ is_space['\t'] = 1;
+ is_space['\v'] = 1;
+ is_space['\f'] = 1;
+ is_space['\n'] = 1;
+ is_space['\r'] = 1;
+}
- if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
- return build_pointer_type (char_type_node);
+static void
+ffecom_close_include_ (FILE *f)
+{
+ fclose (f);
- if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
- return build_pointer_type (integer_type_node);
+ indepth--;
+ input_file_stack_tick++;
- 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;
- }
- }
+ ffewhere_line_kill (instack[indepth].line);
+ ffewhere_column_kill (instack[indepth].column);
+}
- return 0;
+static int
+ffecom_decode_include_option_ (char *spec)
+{
+ struct file_name_list *dirtmp;
+
+ if (! ignore_srcdir && !strcmp (spec, "-"))
+ ignore_srcdir = 1;
+ else
+ {
+ dirtmp = (struct file_name_list *)
+ xmalloc (sizeof (struct file_name_list));
+ dirtmp->next = 0; /* New one goes on the end */
+ if (spec[0] != 0)
+ dirtmp->fname = spec;
+ else
+ fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
+ dirtmp->got_name_map = 0;
+ append_include_chain (dirtmp, dirtmp);
+ }
+ return 1;
}
-tree
-type_for_size (bits, unsignedp)
- unsigned bits;
- int unsignedp;
+/* Open INCLUDEd file. */
+
+static FILE *
+ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
{
- ffeinfoKindtype kt;
- tree type_node;
+ char *fbeg = name;
+ size_t flen = strlen (fbeg);
+ struct file_name_list *search_start = include; /* Chain of dirs to search */
+ struct file_name_list dsp[1]; /* First in chain, if #include "..." */
+ struct file_name_list *searchptr = 0;
+ char *fname; /* Dynamically allocated fname buffer */
+ FILE *f;
+ FILE_BUF *fp;
- if (bits == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
+ if (flen == 0)
+ return NULL;
- if (bits == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ dsp[0].fname = NULL;
- if (bits == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+ /* If -I- was specified, don't search current dir, only spec'd ones. */
+ if (!ignore_srcdir)
+ {
+ for (fp = &instack[indepth]; fp >= instack; fp--)
+ {
+ int n;
+ char *ep;
+ char *nam;
- if (bits == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+ if ((nam = fp->nominal_fname) != NULL)
+ {
+ /* Found a named file. Figure out dir of the file,
+ and put it in front of the search list. */
+ dsp[0].next = search_start;
+ search_start = dsp;
+#ifndef VMS
+ ep = rindex (nam, '/');
+#ifdef DIR_SEPARATOR
+ if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
+ else {
+ char *tmp = rindex (nam, DIR_SEPARATOR);
+ if (tmp != NULL && tmp > ep) ep = tmp;
+ }
+#endif
+#else /* VMS */
+ ep = rindex (nam, ']');
+ if (ep == NULL) ep = rindex (nam, '>');
+ if (ep == NULL) ep = rindex (nam, ':');
+ if (ep != NULL) ep++;
+#endif /* VMS */
+ if (ep != NULL)
+ {
+ n = ep - nam;
+ dsp[0].fname = (char *) xmalloc (n + 1);
+ strncpy (dsp[0].fname, nam, n);
+ dsp[0].fname[n] = '\0';
+ if (n + INCLUDE_LEN_FUDGE > max_include_len)
+ max_include_len = n + INCLUDE_LEN_FUDGE;
+ }
+ else
+ dsp[0].fname = NULL; /* Current directory */
+ dsp[0].got_name_map = 0;
+ break;
+ }
+ }
+ }
- if (bits == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
+ /* Allocate this permanently, because it gets stored in the definitions
+ of macros. */
+ fname = xmalloc (max_include_len + flen + 4);
+ /* + 2 above for slash and terminating null. */
+ /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
+ for g77 yet). */
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
- {
- type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ /* If specified file name is absolute, just open it. */
- if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
- return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
- : type_node;
+ if (*fbeg == '/'
+#ifdef DIR_SEPARATOR
+ || *fbeg == DIR_SEPARATOR
+#endif
+ )
+ {
+ strncpy (fname, (char *) fbeg, flen);
+ fname[flen] = 0;
+ f = open_include_file (fname, NULL_PTR);
}
+ else
+ {
+ f = NULL;
- return 0;
-}
+ /* Search directory path, trying to open the file.
+ Copy each filename tried into FNAME. */
-tree
-unsigned_type (type)
- tree type;
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
+ for (searchptr = search_start; searchptr; searchptr = searchptr->next)
+ {
+ if (searchptr->fname)
+ {
+ /* The empty string in a search path is ignored.
+ This makes it possible to turn off entirely
+ a standard piece of the list. */
+ if (searchptr->fname[0] == 0)
+ continue;
+ strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
+ if (fname[0] && fname[strlen (fname) - 1] != '/')
+ strcat (fname, "/");
+ fname[strlen (fname) + flen] = 0;
+ }
+ else
+ fname[0] = 0;
- if (type1 == signed_char_type_node || type1 == char_type_node)
- return unsigned_char_type_node;
- if (type1 == integer_type_node)
- return unsigned_type_node;
- if (type1 == short_integer_type_node)
- return short_unsigned_type_node;
- if (type1 == long_integer_type_node)
- return long_unsigned_type_node;
- if (type1 == long_long_integer_type_node)
- return long_long_unsigned_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == intDI_type_node)
- return unsigned_intDI_type_node;
- if (type1 == intSI_type_node)
- return unsigned_intSI_type_node;
- if (type1 == intHI_type_node)
- return unsigned_intHI_type_node;
- if (type1 == intQI_type_node)
- return unsigned_intQI_type_node;
+ strncat (fname, fbeg, flen);
+#ifdef VMS
+ /* Change this 1/2 Unix 1/2 VMS file specification into a
+ full VMS file specification */
+ if (searchptr->fname && (searchptr->fname[0] != 0))
+ {
+ /* Fix up the filename */
+ hack_vms_include_specification (fname);
+ }
+ else
+ {
+ /* This is a normal VMS filespec, so use it unchanged. */
+ strncpy (fname, (char *) fbeg, flen);
+ fname[flen] = 0;
+#if 0 /* Not for g77. */
+ /* if it's '#include filename', add the missing .h */
+ if (index (fname, '.') == NULL)
+ strcat (fname, ".h");
#endif
+ }
+#endif /* VMS */
+ f = open_include_file (fname, searchptr);
+#ifdef EACCES
+ if (f == NULL && errno == EACCES)
+ {
+ print_containing_files (FFEBAD_severityWARNING);
+ ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
+ FFEBAD_severityWARNING);
+ ffebad_string (fname);
+ ffebad_here (0, l, c);
+ ffebad_finish ();
+ }
+#endif
+ if (f != NULL)
+ break;
+ }
+ }
- type2 = type_for_size (TYPE_PRECISION (type1), 1);
- if (type2 != NULL_TREE)
- return type2;
-
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ if (f == NULL)
{
- type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ /* A file that was not found. */
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+ 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 ();
}
- return type;
-}
-
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-\f
-#if FFECOM_GCC_INCLUDE
-
-/* From gcc/cccp.c, the code to handle -I. */
-
-/* Skip leading "./" from a directory name.
- This may yield the empty string, which represents the current directory. */
+ if (dsp[0].fname != NULL)
+ free (dsp[0].fname);
-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;
-}
+ if (f == NULL)
+ return NULL;
-/* The file_name_map structure holds a mapping of file names for a
- particular directory. This mapping is read from the file named
- FILE_NAME_MAP_FILE in that directory. Such a file can be used to
- map filenames on a file system with severe filename restrictions,
- such as DOS. The format of the file name map file is just a series
- of lines with two tokens on each line. The first token is the name
- to map, and the second token is the actual name to use. */
+ 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;
+ }
-struct file_name_map
-{
- struct file_name_map *map_next;
- char *map_from;
- char *map_to;
-};
+ instack[indepth].line = ffewhere_line_use (l);
+ instack[indepth].column = ffewhere_column_use (c);
-#define FILE_NAME_MAP_FILE "header.gcc"
+ fp = &instack[indepth + 1];
+ memset ((char *) fp, 0, sizeof (FILE_BUF));
+ fp->nominal_fname = fp->fname = fname;
+ fp->dir = searchptr;
-/* Current maximum length of directory names in the search path
- for include files. (Altered as we get more of them.) */
+ indepth++;
+ input_file_stack_tick++;
-static int max_include_len = 0;
+ return f;
+}
+#endif /* FFECOM_GCC_INCLUDE */
-struct file_name_list
- {
- struct file_name_list *next;
- char *fname;
- /* Mapping of file names for this directory. */
- struct file_name_map *name_map;
- /* Non-zero if name_map is valid. */
- int got_name_map;
- };
+/**INDENT* (Do not reformat this comment even with -fca option.)
+ Data-gathering files: Given the source file listed below, compiled with
+ f2c I obtained the output file listed after that, and from the output
+ file I derived the above code.
-static struct file_name_list *include = NULL; /* First dir to search */
-static struct file_name_list *last_include = NULL; /* Last in chain */
+-------- (begin input file to f2c)
+ implicit none
+ character*10 A1,A2
+ complex C1,C2
+ integer I1,I2
+ real R1,R2
+ double precision D1,D2
+C
+ call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
+c /
+ call fooI(I1/I2)
+ call fooR(R1/I1)
+ call fooD(D1/I1)
+ call fooC(C1/I1)
+ call fooR(R1/R2)
+ call fooD(R1/D1)
+ call fooD(D1/D2)
+ call fooD(D1/R1)
+ call fooC(C1/C2)
+ call fooC(C1/R1)
+ call fooZ(C1/D1)
+c **
+ call fooI(I1**I2)
+ call fooR(R1**I1)
+ call fooD(D1**I1)
+ call fooC(C1**I1)
+ call fooR(R1**R2)
+ call fooD(R1**D1)
+ call fooD(D1**D2)
+ call fooD(D1**R1)
+ call fooC(C1**C2)
+ call fooC(C1**R1)
+ call fooZ(C1**D1)
+c FFEINTRIN_impABS
+ call fooR(ABS(R1))
+c FFEINTRIN_impACOS
+ call fooR(ACOS(R1))
+c FFEINTRIN_impAIMAG
+ call fooR(AIMAG(C1))
+c FFEINTRIN_impAINT
+ call fooR(AINT(R1))
+c FFEINTRIN_impALOG
+ call fooR(ALOG(R1))
+c FFEINTRIN_impALOG10
+ call fooR(ALOG10(R1))
+c FFEINTRIN_impAMAX0
+ call fooR(AMAX0(I1,I2))
+c FFEINTRIN_impAMAX1
+ call fooR(AMAX1(R1,R2))
+c FFEINTRIN_impAMIN0
+ call fooR(AMIN0(I1,I2))
+c FFEINTRIN_impAMIN1
+ call fooR(AMIN1(R1,R2))
+c FFEINTRIN_impAMOD
+ call fooR(AMOD(R1,R2))
+c FFEINTRIN_impANINT
+ call fooR(ANINT(R1))
+c FFEINTRIN_impASIN
+ call fooR(ASIN(R1))
+c FFEINTRIN_impATAN
+ call fooR(ATAN(R1))
+c FFEINTRIN_impATAN2
+ call fooR(ATAN2(R1,R2))
+c FFEINTRIN_impCABS
+ call fooR(CABS(C1))
+c FFEINTRIN_impCCOS
+ call fooC(CCOS(C1))
+c FFEINTRIN_impCEXP
+ call fooC(CEXP(C1))
+c FFEINTRIN_impCHAR
+ call fooA(CHAR(I1))
+c FFEINTRIN_impCLOG
+ call fooC(CLOG(C1))
+c FFEINTRIN_impCONJG
+ call fooC(CONJG(C1))
+c FFEINTRIN_impCOS
+ call fooR(COS(R1))
+c FFEINTRIN_impCOSH
+ call fooR(COSH(R1))
+c FFEINTRIN_impCSIN
+ call fooC(CSIN(C1))
+c FFEINTRIN_impCSQRT
+ call fooC(CSQRT(C1))
+c FFEINTRIN_impDABS
+ call fooD(DABS(D1))
+c FFEINTRIN_impDACOS
+ call fooD(DACOS(D1))
+c FFEINTRIN_impDASIN
+ call fooD(DASIN(D1))
+c FFEINTRIN_impDATAN
+ call fooD(DATAN(D1))
+c FFEINTRIN_impDATAN2
+ call fooD(DATAN2(D1,D2))
+c FFEINTRIN_impDCOS
+ call fooD(DCOS(D1))
+c FFEINTRIN_impDCOSH
+ call fooD(DCOSH(D1))
+c FFEINTRIN_impDDIM
+ call fooD(DDIM(D1,D2))
+c FFEINTRIN_impDEXP
+ call fooD(DEXP(D1))
+c FFEINTRIN_impDIM
+ call fooR(DIM(R1,R2))
+c FFEINTRIN_impDINT
+ call fooD(DINT(D1))
+c FFEINTRIN_impDLOG
+ call fooD(DLOG(D1))
+c FFEINTRIN_impDLOG10
+ call fooD(DLOG10(D1))
+c FFEINTRIN_impDMAX1
+ call fooD(DMAX1(D1,D2))
+c FFEINTRIN_impDMIN1
+ call fooD(DMIN1(D1,D2))
+c FFEINTRIN_impDMOD
+ call fooD(DMOD(D1,D2))
+c FFEINTRIN_impDNINT
+ call fooD(DNINT(D1))
+c FFEINTRIN_impDPROD
+ call fooD(DPROD(R1,R2))
+c FFEINTRIN_impDSIGN
+ call fooD(DSIGN(D1,D2))
+c FFEINTRIN_impDSIN
+ call fooD(DSIN(D1))
+c FFEINTRIN_impDSINH
+ call fooD(DSINH(D1))
+c FFEINTRIN_impDSQRT
+ call fooD(DSQRT(D1))
+c FFEINTRIN_impDTAN
+ call fooD(DTAN(D1))
+c FFEINTRIN_impDTANH
+ call fooD(DTANH(D1))
+c FFEINTRIN_impEXP
+ call fooR(EXP(R1))
+c FFEINTRIN_impIABS
+ call fooI(IABS(I1))
+c FFEINTRIN_impICHAR
+ call fooI(ICHAR(A1))
+c FFEINTRIN_impIDIM
+ call fooI(IDIM(I1,I2))
+c FFEINTRIN_impIDNINT
+ call fooI(IDNINT(D1))
+c FFEINTRIN_impINDEX
+ call fooI(INDEX(A1,A2))
+c FFEINTRIN_impISIGN
+ call fooI(ISIGN(I1,I2))
+c FFEINTRIN_impLEN
+ call fooI(LEN(A1))
+c FFEINTRIN_impLGE
+ call fooL(LGE(A1,A2))
+c FFEINTRIN_impLGT
+ call fooL(LGT(A1,A2))
+c FFEINTRIN_impLLE
+ call fooL(LLE(A1,A2))
+c FFEINTRIN_impLLT
+ call fooL(LLT(A1,A2))
+c FFEINTRIN_impMAX0
+ call fooI(MAX0(I1,I2))
+c FFEINTRIN_impMAX1
+ call fooI(MAX1(R1,R2))
+c FFEINTRIN_impMIN0
+ call fooI(MIN0(I1,I2))
+c FFEINTRIN_impMIN1
+ call fooI(MIN1(R1,R2))
+c FFEINTRIN_impMOD
+ call fooI(MOD(I1,I2))
+c FFEINTRIN_impNINT
+ call fooI(NINT(R1))
+c FFEINTRIN_impSIGN
+ call fooR(SIGN(R1,R2))
+c FFEINTRIN_impSIN
+ call fooR(SIN(R1))
+c FFEINTRIN_impSINH
+ call fooR(SINH(R1))
+c FFEINTRIN_impSQRT
+ call fooR(SQRT(R1))
+c FFEINTRIN_impTAN
+ call fooR(TAN(R1))
+c FFEINTRIN_impTANH
+ call fooR(TANH(R1))
+c FFEINTRIN_imp_CMPLX_C
+ call fooC(cmplx(C1,C2))
+c FFEINTRIN_imp_CMPLX_D
+ call fooZ(cmplx(D1,D2))
+c FFEINTRIN_imp_CMPLX_I
+ call fooC(cmplx(I1,I2))
+c FFEINTRIN_imp_CMPLX_R
+ call fooC(cmplx(R1,R2))
+c FFEINTRIN_imp_DBLE_C
+ call fooD(dble(C1))
+c FFEINTRIN_imp_DBLE_D
+ call fooD(dble(D1))
+c FFEINTRIN_imp_DBLE_I
+ call fooD(dble(I1))
+c FFEINTRIN_imp_DBLE_R
+ call fooD(dble(R1))
+c FFEINTRIN_imp_INT_C
+ call fooI(int(C1))
+c FFEINTRIN_imp_INT_D
+ call fooI(int(D1))
+c FFEINTRIN_imp_INT_I
+ call fooI(int(I1))
+c FFEINTRIN_imp_INT_R
+ call fooI(int(R1))
+c FFEINTRIN_imp_REAL_C
+ call fooR(real(C1))
+c FFEINTRIN_imp_REAL_D
+ call fooR(real(D1))
+c FFEINTRIN_imp_REAL_I
+ call fooR(real(I1))
+c FFEINTRIN_imp_REAL_R
+ call fooR(real(R1))
+c
+c FFEINTRIN_imp_INT_D:
+c
+c FFEINTRIN_specIDINT
+ call fooI(IDINT(D1))
+c
+c FFEINTRIN_imp_INT_R:
+c
+c FFEINTRIN_specIFIX
+ call fooI(IFIX(R1))
+c FFEINTRIN_specINT
+ call fooI(INT(R1))
+c
+c FFEINTRIN_imp_REAL_D:
+c
+c FFEINTRIN_specSNGL
+ call fooR(SNGL(D1))
+c
+c FFEINTRIN_imp_REAL_I:
+c
+c FFEINTRIN_specFLOAT
+ call fooR(FLOAT(I1))
+c FFEINTRIN_specREAL
+ call fooR(REAL(I1))
+c
+ end
+-------- (end input file to f2c)
-/* I/O buffer structure.
- The `fname' field is nonzero for source files and #include files
- and for the dummy text used for -D and -U.
- It is zero for rescanning results of macro expansion
- and for expanding macro arguments. */
-#define INPUT_STACK_MAX 400
-static struct file_buf {
- char *fname;
- /* Filename specified with #line command. */
- char *nominal_fname;
- /* Record where in the search path this file was found.
- For #include_next. */
- struct file_name_list *dir;
- ffewhereLine line;
- ffewhereColumn column;
-} instack[INPUT_STACK_MAX];
+-------- (begin output from providing above input file as input to:
+-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
+-------- -e "s:^#.*$::g"')
-static int last_error_tick = 0; /* Incremented each time we print it. */
-static int input_file_stack_tick = 0; /* Incremented when status changes. */
+// -- translated by f2c (version 19950223).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+//
-/* Current nesting level of input sources.
- `instack[indepth]' is the level currently being read. */
-static int indepth = -1;
-typedef struct file_buf FILE_BUF;
+// f2c.h -- Standard Fortran to C header file //
-typedef unsigned char U_CHAR;
+/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
-/* table to tell if char can be part of a C identifier. */
-U_CHAR is_idchar[256];
-/* table to tell if char can be first char of a c identifier. */
-U_CHAR is_idstart[256];
-/* table to tell if c is horizontal space. */
-U_CHAR is_hor_space[256];
-/* table to tell if c is horizontal or vertical space. */
-static U_CHAR is_space[256];
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
-#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
-#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
-/* Nonzero means -I- has been seen,
- so don't look for #include "foo" the source-file directory. */
-static int ignore_srcdir;
-#ifndef INCLUDE_LEN_FUDGE
-#define INCLUDE_LEN_FUDGE 0
-#endif
-static void append_include_chain (struct file_name_list *first,
- struct file_name_list *last);
-static FILE *open_include_file (char *filename,
- struct file_name_list *searchptr);
-static void print_containing_files (ffebadSeverity sev);
-static const char *skip_redundant_dir_prefix (const char *);
-static char *read_filename_string (int ch, FILE *f);
-static struct file_name_map *read_name_map (const char *dirname);
+// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
+// we assume short, float are OK //
+typedef long int // long int // integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int // long int // logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+// typedef long long longint; // // system-dependent //
-/* Append a chain of `struct file_name_list's
- to the end of the main include chain.
- FIRST is the beginning of the chain to append, and LAST is the end. */
-static void
-append_include_chain (first, last)
- struct file_name_list *first, *last;
-{
- struct file_name_list *dir;
- if (!first || !last)
- return;
- if (include == 0)
- include = first;
- else
- last_include->next = first;
+// Extern is for use with -E //
- for (dir = first; ; dir = dir->next) {
- int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
- if (len > max_include_len)
- max_include_len = len;
- if (dir == last)
- break;
- }
- last->next = NULL;
- last_include = last;
-}
-/* Try to open include file FILENAME. SEARCHPTR is the directory
- being tried from the include file search path. This function maps
- filenames on file systems based on information read by
- read_name_map. */
-static FILE *
-open_include_file (filename, searchptr)
- char *filename;
- struct file_name_list *searchptr;
-{
- register struct file_name_map *map;
- register char *from;
- char *p, *dir;
+// I/O stuff //
- if (searchptr && ! searchptr->got_name_map)
- {
- searchptr->name_map = read_name_map (searchptr->fname
- ? searchptr->fname : ".");
- searchptr->got_name_map = 1;
- }
- /* First check the mapping for the directory we are using. */
- if (searchptr && searchptr->name_map)
- {
- from = filename;
- if (searchptr->fname)
- from += strlen (searchptr->fname) + 1;
- for (map = searchptr->name_map; map; map = map->map_next)
- {
- if (! strcmp (map->map_from, from))
- {
- /* Found a match. */
- return fopen (map->map_to, "r");
- }
- }
- }
- /* Try to find a mapping file for the particular directory we are
- looking in. Thus #include <sys/types.h> will look up sys/types.h
- in /usr/include/header.gcc and look up types.h in
- /usr/include/sys/header.gcc. */
- p = rindex (filename, '/');
-#ifdef DIR_SEPARATOR
- if (! p) p = rindex (filename, DIR_SEPARATOR);
- else {
- char *tmp = rindex (filename, DIR_SEPARATOR);
- if (tmp != NULL && tmp > p) p = tmp;
- }
-#endif
- if (! p)
- p = filename;
- if (searchptr
- && searchptr->fname
- && strlen (searchptr->fname) == (size_t) (p - filename)
- && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
- {
- /* FILENAME is in SEARCHPTR, which we've already checked. */
- return fopen (filename, "r");
- }
- if (p == filename)
- {
- from = filename;
- map = read_name_map (".");
- }
- else
- {
- dir = (char *) xmalloc (p - filename + 1);
- memcpy (dir, filename, p - filename);
- dir[p - filename] = '\0';
- from = p + 1;
- map = read_name_map (dir);
- free (dir);
- }
- for (; map; map = map->map_next)
- if (! strcmp (map->map_from, from))
- return fopen (map->map_to, "r");
- return fopen (filename, "r");
-}
-/* Print the file names and line numbers of the #include
- commands which led to the current file. */
-static void
-print_containing_files (ffebadSeverity sev)
-{
- FILE_BUF *ip = NULL;
- int i;
- int first = 1;
- const char *str1;
- const char *str2;
- /* If stack of files hasn't changed since we last printed
- this info, don't repeat it. */
- if (last_error_tick == input_file_stack_tick)
- return;
+typedef long int // int or long int // flag;
+typedef long int // int or long int // ftnlen;
+typedef long int // int or long int // ftnint;
- for (i = indepth; i >= 0; i--)
- if (instack[i].fname != NULL) {
- ip = &instack[i];
- break;
- }
- /* Give up if we don't find a source file. */
- if (ip == NULL)
- return;
+//external read, write//
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
- /* Find the other, outer source files. */
- for (i--; i >= 0; i--)
- if (instack[i].fname != NULL)
- {
- ip = &instack[i];
- if (first)
- {
- first = 0;
- str1 = "In file included";
- }
- else
- {
- str1 = "... ...";
- }
+//internal read, write//
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
- if (i == 1)
- str2 = ":";
- else
- str2 = "";
+//open//
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
- 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 ();
- }
+//close//
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
- /* Record we have printed the status as of this time. */
- last_error_tick = input_file_stack_tick;
-}
+//rewind, backspace, endfile//
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
-/* Read a space delimited string of unlimited length from a stdio
- file. */
+// inquire //
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; //parameters in standard's order//
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
-static char *
-read_filename_string (ch, f)
- int ch;
- FILE *f;
-{
- char *alloc, *set;
- int len;
- len = 20;
- set = alloc = xmalloc (len + 1);
- if (! is_space[ch])
- {
- *set++ = ch;
- while ((ch = getc (f)) != EOF && ! is_space[ch])
- {
- if (set - alloc == len)
- {
- len *= 2;
- alloc = xrealloc (alloc, len + 1);
- set = alloc + len / 2;
- }
- *set++ = ch;
- }
- }
- *set = '\0';
- ungetc (ch, f);
- return alloc;
-}
-/* Read the file name map file for DIRNAME. */
+union Multitype { // for multiple entry points //
+ integer1 g;
+ shortint h;
+ integer i;
+ // longint j; //
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
-static struct file_name_map *
-read_name_map (dirname)
- const char *dirname;
-{
- /* This structure holds a linked list of file name maps, one per
- directory. */
- struct file_name_map_list
- {
- struct file_name_map_list *map_list_next;
- char *map_list_name;
- struct file_name_map *map_list_map;
- };
- static struct file_name_map_list *map_list;
- register struct file_name_map_list *map_list_ptr;
- char *name;
- FILE *f;
- size_t dirlen;
- int separator_needed;
+typedef long Long; // No longer used; formerly in Namelist //
- dirname = skip_redundant_dir_prefix (dirname);
+struct Vardesc { // for Namelist //
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
- 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;
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
- 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] != '/';
- name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
- strcpy (name, dirname);
- name[dirlen] = '/';
- strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
- f = fopen (name, "r");
- free (name);
- if (!f)
- map_list_ptr->map_list_map = NULL;
- else
- {
- int ch;
- while ((ch = getc (f)) != EOF)
- {
- char *from, *to;
- struct file_name_map *ptr;
- if (is_space[ch])
- continue;
- from = read_filename_string (ch, f);
- while ((ch = getc (f)) != EOF && is_hor_space[ch])
- ;
- to = read_filename_string (ch, f);
- ptr = ((struct file_name_map *)
- xmalloc (sizeof (struct file_name_map)));
- ptr->map_from = from;
- /* Make the real filename absolute. */
- if (*to == '/')
- ptr->map_to = to;
- else
- {
- ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
- strcpy (ptr->map_to, dirname);
- ptr->map_to[dirlen] = '/';
- strcpy (ptr->map_to + dirlen + separator_needed, to);
- free (to);
- }
- ptr->map_next = map_list_ptr->map_list_map;
- map_list_ptr->map_list_map = ptr;
- while ((ch = getc (f)) != '\n')
- if (ch == EOF)
- break;
- }
- fclose (f);
- }
+// procedure parameter types for -A and -C++ //
- map_list_ptr->map_list_next = map_list;
- map_list = map_list_ptr;
- return map_list_ptr->map_list_map;
-}
-static void
-ffecom_file_ (char *name)
-{
- FILE_BUF *fp;
- /* Do partial setup of input buffer for the sake of generating
- early #line directives (when -g is in effect). */
+typedef int // Unknown procedure type // (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef // Complex // void (*C_fp)();
+typedef // Double Complex // void (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef // Character // void (*H_fp)();
+typedef // Subroutine // int (*S_fp)();
- fp = &instack[++indepth];
- memset ((char *) fp, 0, sizeof (FILE_BUF));
- if (name == NULL)
- name = "";
- fp->nominal_fname = fp->fname = name;
-}
+// E_fp is for real functions when -R is not specified //
+typedef void C_f; // complex function //
+typedef void H_f; // character function //
+typedef void Z_f; // double complex function //
+typedef doublereal E_f; // real function with -R not specified //
-/* Initialize syntactic classifications of characters. */
+// undef any lower-case symbols that your C compiler predefines, e.g.: //
-static void
-ffecom_initialize_char_syntax_ ()
-{
- register int i;
- /*
- * Set up is_idchar and is_idstart tables. These should be
- * faster than saying (is_alpha (c) || c == '_'), etc.
- * Set up these things before calling any routines tthat
- * refer to them.
- */
- for (i = 'a'; i <= 'z'; i++) {
- is_idchar[i - 'a' + 'A'] = 1;
- is_idchar[i] = 1;
- is_idstart[i - 'a' + 'A'] = 1;
- is_idstart[i] = 1;
- }
- for (i = '0'; i <= '9'; i++)
- is_idchar[i] = 1;
- is_idchar['_'] = 1;
- is_idstart['_'] = 1;
+// (No such symbols should be defined in a strict ANSI C compiler.
+ We can avoid trouble with f2c-translated code by using
+ gcc -ansi [-traditional].) //
+
- /* horizontal space table */
- is_hor_space[' '] = 1;
- is_hor_space['\t'] = 1;
- is_hor_space['\v'] = 1;
- is_hor_space['\f'] = 1;
- is_hor_space['\r'] = 1;
- is_space[' '] = 1;
- is_space['\t'] = 1;
- is_space['\v'] = 1;
- is_space['\f'] = 1;
- is_space['\n'] = 1;
- is_space['\r'] = 1;
-}
-static void
-ffecom_close_include_ (FILE *f)
-{
- fclose (f);
- indepth--;
- input_file_stack_tick++;
- ffewhere_line_kill (instack[indepth].line);
- ffewhere_column_kill (instack[indepth].column);
-}
-static int
-ffecom_decode_include_option_ (char *spec)
-{
- struct file_name_list *dirtmp;
- if (! ignore_srcdir && !strcmp (spec, "-"))
- ignore_srcdir = 1;
- else
- {
- dirtmp = (struct file_name_list *)
- xmalloc (sizeof (struct file_name_list));
- dirtmp->next = 0; /* New one goes on the end */
- if (spec[0] != 0)
- dirtmp->fname = spec;
- else
- fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
- dirtmp->got_name_map = 0;
- append_include_chain (dirtmp, dirtmp);
- }
- return 1;
-}
-/* Open INCLUDEd file. */
-static FILE *
-ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
-{
- char *fbeg = name;
- size_t flen = strlen (fbeg);
- struct file_name_list *search_start = include; /* Chain of dirs to search */
- struct file_name_list dsp[1]; /* First in chain, if #include "..." */
- struct file_name_list *searchptr = 0;
- char *fname; /* Dynamically allocated fname buffer */
- FILE *f;
- FILE_BUF *fp;
- if (flen == 0)
- return NULL;
- dsp[0].fname = NULL;
- /* If -I- was specified, don't search current dir, only spec'd ones. */
- if (!ignore_srcdir)
- {
- for (fp = &instack[indepth]; fp >= instack; fp--)
- {
- int n;
- char *ep;
- char *nam;
- if ((nam = fp->nominal_fname) != NULL)
- {
- /* Found a named file. Figure out dir of the file,
- and put it in front of the search list. */
- dsp[0].next = search_start;
- search_start = dsp;
-#ifndef VMS
- ep = rindex (nam, '/');
-#ifdef DIR_SEPARATOR
- if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
- else {
- char *tmp = rindex (nam, DIR_SEPARATOR);
- if (tmp != NULL && tmp > ep) ep = tmp;
- }
-#endif
-#else /* VMS */
- ep = rindex (nam, ']');
- if (ep == NULL) ep = rindex (nam, '>');
- if (ep == NULL) ep = rindex (nam, ':');
- if (ep != NULL) ep++;
-#endif /* VMS */
- if (ep != NULL)
- {
- n = ep - nam;
- dsp[0].fname = (char *) xmalloc (n + 1);
- strncpy (dsp[0].fname, nam, n);
- dsp[0].fname[n] = '\0';
- if (n + INCLUDE_LEN_FUDGE > max_include_len)
- max_include_len = n + INCLUDE_LEN_FUDGE;
- }
- else
- dsp[0].fname = NULL; /* Current directory */
- dsp[0].got_name_map = 0;
- break;
- }
- }
- }
- /* Allocate this permanently, because it gets stored in the definitions
- of macros. */
- fname = xmalloc (max_include_len + flen + 4);
- /* + 2 above for slash and terminating null. */
- /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
- for g77 yet). */
- /* If specified file name is absolute, just open it. */
- if (*fbeg == '/'
-#ifdef DIR_SEPARATOR
- || *fbeg == DIR_SEPARATOR
-#endif
- )
- {
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- f = open_include_file (fname, NULL_PTR);
- }
- else
- {
- f = NULL;
- /* Search directory path, trying to open the file.
- Copy each filename tried into FNAME. */
- for (searchptr = search_start; searchptr; searchptr = searchptr->next)
- {
- if (searchptr->fname)
- {
- /* The empty string in a search path is ignored.
- This makes it possible to turn off entirely
- a standard piece of the list. */
- if (searchptr->fname[0] == 0)
- continue;
- strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
- if (fname[0] && fname[strlen (fname) - 1] != '/')
- strcat (fname, "/");
- fname[strlen (fname) + flen] = 0;
- }
- else
- fname[0] = 0;
- strncat (fname, fbeg, flen);
-#ifdef VMS
- /* Change this 1/2 Unix 1/2 VMS file specification into a
- full VMS file specification */
- if (searchptr->fname && (searchptr->fname[0] != 0))
- {
- /* Fix up the filename */
- hack_vms_include_specification (fname);
- }
- else
- {
- /* This is a normal VMS filespec, so use it unchanged. */
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
-#if 0 /* Not for g77. */
- /* if it's '#include filename', add the missing .h */
- if (index (fname, '.') == NULL)
- strcat (fname, ".h");
-#endif
- }
-#endif /* VMS */
- f = open_include_file (fname, searchptr);
-#ifdef EACCES
- if (f == NULL && errno == EACCES)
- {
- print_containing_files (FFEBAD_severityWARNING);
- ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
- FFEBAD_severityWARNING);
- ffebad_string (fname);
- ffebad_here (0, l, c);
- ffebad_finish ();
- }
-#endif
- if (f != NULL)
- break;
- }
- }
- if (f == NULL)
- {
- /* A file that was not found. */
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
- ffebad_start (FFEBAD_OPEN_INCLUDE);
- ffebad_here (0, l, c);
- ffebad_string (fname);
- ffebad_finish ();
- }
- if (dsp[0].fname != NULL)
- free (dsp[0].fname);
+// Main program // MAIN__()
+{
+ // System generated locals //
+ integer i__1;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+ complex q__1;
+ doublecomplex z__1, z__2, z__3;
+ logical L__1;
+ char ch__1[1];
+
+ // Builtin functions //
+ void c_div();
+ integer pow_ii();
+ double pow_ri(), pow_di();
+ void pow_ci();
+ double pow_dd();
+ void pow_zz();
+ double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
+ asin(), atan(), atan2(), c_abs();
+ void c_cos(), c_exp(), c_log(), r_cnjg();
+ double cos(), cosh();
+ void c_sin(), c_sqrt();
+ double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
+ d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
+ integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
+ logical l_ge(), l_gt(), l_le(), l_lt();
+ integer i_nint();
+ double r_sign();
+
+ // Local variables //
+ extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
+ fool_(), fooz_(), getem_();
+ static char a1[10], a2[10];
+ static complex c1, c2;
+ static doublereal d1, d2;
+ static integer i1, i2;
+ static real r1, r2;
+
+
+ getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
+// / //
+ i__1 = i1 / i2;
+ fooi_(&i__1);
+ r__1 = r1 / i1;
+ foor_(&r__1);
+ d__1 = d1 / i1;
+ food_(&d__1);
+ d__1 = (doublereal) i1;
+ q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
+ fooc_(&q__1);
+ r__1 = r1 / r2;
+ foor_(&r__1);
+ d__1 = r1 / d1;
+ food_(&d__1);
+ d__1 = d1 / d2;
+ food_(&d__1);
+ d__1 = d1 / r1;
+ food_(&d__1);
+ c_div(&q__1, &c1, &c2);
+ fooc_(&q__1);
+ q__1.r = c1.r / r1, q__1.i = c1.i / r1;
+ fooc_(&q__1);
+ z__1.r = c1.r / d1, z__1.i = c1.i / d1;
+ fooz_(&z__1);
+// ** //
+ i__1 = pow_ii(&i1, &i2);
+ fooi_(&i__1);
+ r__1 = pow_ri(&r1, &i1);
+ foor_(&r__1);
+ d__1 = pow_di(&d1, &i1);
+ food_(&d__1);
+ pow_ci(&q__1, &c1, &i1);
+ fooc_(&q__1);
+ d__1 = (doublereal) r1;
+ d__2 = (doublereal) r2;
+ r__1 = pow_dd(&d__1, &d__2);
+ foor_(&r__1);
+ d__2 = (doublereal) r1;
+ d__1 = pow_dd(&d__2, &d1);
+ food_(&d__1);
+ d__1 = pow_dd(&d1, &d2);
+ food_(&d__1);
+ d__2 = (doublereal) r1;
+ d__1 = pow_dd(&d1, &d__2);
+ food_(&d__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = c2.r, z__3.i = c2.i;
+ pow_zz(&z__1, &z__2, &z__3);
+ q__1.r = z__1.r, q__1.i = z__1.i;
+ fooc_(&q__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = r1, z__3.i = 0.;
+ pow_zz(&z__1, &z__2, &z__3);
+ q__1.r = z__1.r, q__1.i = z__1.i;
+ fooc_(&q__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = d1, z__3.i = 0.;
+ pow_zz(&z__1, &z__2, &z__3);
+ fooz_(&z__1);
+// FFEINTRIN_impABS //
+ r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impACOS //
+ r__1 = acos(r1);
+ foor_(&r__1);
+// FFEINTRIN_impAIMAG //
+ r__1 = r_imag(&c1);
+ foor_(&r__1);
+// FFEINTRIN_impAINT //
+ r__1 = r_int(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impALOG //
+ r__1 = log(r1);
+ foor_(&r__1);
+// FFEINTRIN_impALOG10 //
+ r__1 = r_lg10(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impAMAX0 //
+ r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMAX1 //
+ r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMIN0 //
+ r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMIN1 //
+ r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMOD //
+ r__1 = r_mod(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impANINT //
+ r__1 = r_nint(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impASIN //
+ r__1 = asin(r1);
+ foor_(&r__1);
+// FFEINTRIN_impATAN //
+ r__1 = atan(r1);
+ foor_(&r__1);
+// FFEINTRIN_impATAN2 //
+ r__1 = atan2(r1, r2);
+ foor_(&r__1);
+// FFEINTRIN_impCABS //
+ r__1 = c_abs(&c1);
+ foor_(&r__1);
+// FFEINTRIN_impCCOS //
+ c_cos(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCEXP //
+ c_exp(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCHAR //
+ *(unsigned char *)&ch__1[0] = i1;
+ fooa_(ch__1, 1L);
+// FFEINTRIN_impCLOG //
+ c_log(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCONJG //
+ r_cnjg(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCOS //
+ r__1 = cos(r1);
+ foor_(&r__1);
+// FFEINTRIN_impCOSH //
+ r__1 = cosh(r1);
+ foor_(&r__1);
+// FFEINTRIN_impCSIN //
+ c_sin(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCSQRT //
+ c_sqrt(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impDABS //
+ d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDACOS //
+ d__1 = acos(d1);
+ food_(&d__1);
+// FFEINTRIN_impDASIN //
+ d__1 = asin(d1);
+ food_(&d__1);
+// FFEINTRIN_impDATAN //
+ d__1 = atan(d1);
+ food_(&d__1);
+// FFEINTRIN_impDATAN2 //
+ d__1 = atan2(d1, d2);
+ food_(&d__1);
+// FFEINTRIN_impDCOS //
+ d__1 = cos(d1);
+ food_(&d__1);
+// FFEINTRIN_impDCOSH //
+ d__1 = cosh(d1);
+ food_(&d__1);
+// FFEINTRIN_impDDIM //
+ d__1 = d_dim(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDEXP //
+ d__1 = exp(d1);
+ food_(&d__1);
+// FFEINTRIN_impDIM //
+ r__1 = r_dim(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impDINT //
+ d__1 = d_int(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDLOG //
+ d__1 = log(d1);
+ food_(&d__1);
+// FFEINTRIN_impDLOG10 //
+ d__1 = d_lg10(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDMAX1 //
+ d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDMIN1 //
+ d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDMOD //
+ d__1 = d_mod(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDNINT //
+ d__1 = d_nint(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDPROD //
+ d__1 = (doublereal) r1 * r2;
+ food_(&d__1);
+// FFEINTRIN_impDSIGN //
+ d__1 = d_sign(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDSIN //
+ d__1 = sin(d1);
+ food_(&d__1);
+// FFEINTRIN_impDSINH //
+ d__1 = sinh(d1);
+ food_(&d__1);
+// FFEINTRIN_impDSQRT //
+ d__1 = sqrt(d1);
+ food_(&d__1);
+// FFEINTRIN_impDTAN //
+ d__1 = tan(d1);
+ food_(&d__1);
+// FFEINTRIN_impDTANH //
+ d__1 = tanh(d1);
+ food_(&d__1);
+// FFEINTRIN_impEXP //
+ r__1 = exp(r1);
+ foor_(&r__1);
+// FFEINTRIN_impIABS //
+ i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impICHAR //
+ i__1 = *(unsigned char *)a1;
+ fooi_(&i__1);
+// FFEINTRIN_impIDIM //
+ i__1 = i_dim(&i1, &i2);
+ fooi_(&i__1);
+// FFEINTRIN_impIDNINT //
+ i__1 = i_dnnt(&d1);
+ fooi_(&i__1);
+// FFEINTRIN_impINDEX //
+ i__1 = i_indx(a1, a2, 10L, 10L);
+ fooi_(&i__1);
+// FFEINTRIN_impISIGN //
+ i__1 = i_sign(&i1, &i2);
+ fooi_(&i__1);
+// FFEINTRIN_impLEN //
+ i__1 = i_len(a1, 10L);
+ fooi_(&i__1);
+// FFEINTRIN_impLGE //
+ L__1 = l_ge(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLGT //
+ L__1 = l_gt(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLLE //
+ L__1 = l_le(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLLT //
+ L__1 = l_lt(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impMAX0 //
+ i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMAX1 //
+ i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMIN0 //
+ i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMIN1 //
+ i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMOD //
+ i__1 = i1 % i2;
+ fooi_(&i__1);
+// FFEINTRIN_impNINT //
+ i__1 = i_nint(&r1);
+ fooi_(&i__1);
+// FFEINTRIN_impSIGN //
+ r__1 = r_sign(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impSIN //
+ r__1 = sin(r1);
+ foor_(&r__1);
+// FFEINTRIN_impSINH //
+ r__1 = sinh(r1);
+ foor_(&r__1);
+// FFEINTRIN_impSQRT //
+ r__1 = sqrt(r1);
+ foor_(&r__1);
+// FFEINTRIN_impTAN //
+ r__1 = tan(r1);
+ foor_(&r__1);
+// FFEINTRIN_impTANH //
+ r__1 = tanh(r1);
+ foor_(&r__1);
+// FFEINTRIN_imp_CMPLX_C //
+ r__1 = c1.r;
+ r__2 = c2.r;
+ q__1.r = r__1, q__1.i = r__2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_CMPLX_D //
+ z__1.r = d1, z__1.i = d2;
+ fooz_(&z__1);
+// FFEINTRIN_imp_CMPLX_I //
+ r__1 = (real) i1;
+ r__2 = (real) i2;
+ q__1.r = r__1, q__1.i = r__2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_CMPLX_R //
+ q__1.r = r1, q__1.i = r2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_DBLE_C //
+ d__1 = (doublereal) c1.r;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_D //
+ d__1 = d1;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_I //
+ d__1 = (doublereal) i1;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_R //
+ d__1 = (doublereal) r1;
+ food_(&d__1);
+// FFEINTRIN_imp_INT_C //
+ i__1 = (integer) c1.r;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_D //
+ i__1 = (integer) d1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_I //
+ i__1 = i1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_R //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_REAL_C //
+ r__1 = c1.r;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_D //
+ r__1 = (real) d1;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_I //
+ r__1 = (real) i1;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_R //
+ r__1 = r1;
+ foor_(&r__1);
+
+// FFEINTRIN_imp_INT_D: //
+
+// FFEINTRIN_specIDINT //
+ i__1 = (integer) d1;
+ fooi_(&i__1);
+
+// FFEINTRIN_imp_INT_R: //
+
+// FFEINTRIN_specIFIX //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+// FFEINTRIN_specINT //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+
+// FFEINTRIN_imp_REAL_D: //
- if (f == NULL)
- return NULL;
+// FFEINTRIN_specSNGL //
+ r__1 = (real) d1;
+ foor_(&r__1);
- 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;
- }
+// FFEINTRIN_imp_REAL_I: //
- instack[indepth].line = ffewhere_line_use (l);
- instack[indepth].column = ffewhere_column_use (c);
+// FFEINTRIN_specFLOAT //
+ r__1 = (real) i1;
+ foor_(&r__1);
+// FFEINTRIN_specREAL //
+ r__1 = (real) i1;
+ foor_(&r__1);
- fp = &instack[indepth + 1];
- memset ((char *) fp, 0, sizeof (FILE_BUF));
- fp->nominal_fname = fp->fname = fname;
- fp->dir = searchptr;
+} // MAIN__ //
- indepth++;
- input_file_stack_tick++;
+-------- (end output file from f2c)
- return f;
-}
-#endif /* FFECOM_GCC_INCLUDE */
+*/
Modifications:
*/
-/* As of 0.5.4, any statement that calls on ffecom to transform an
- expression might need to be wrapped in ffecom_push_calltemps ()
- and ffecom_pop_calltemps () as are some other cases. That is
- the case when the transformation might involve generation of
- a temporary that must be auto-popped, the specific case being
- when a COMPLEX operation requiring a call to libf2c being
- generated, whereby a temp is needed to hold the result since
- libf2c doesn't return COMPLEX results directly. Cases where it
- is known that ffecom_expr () won't need to do this, such as
- the CALL statement (where it's the transformation of the
- call expr itself that does the wrapping), don't need to bother
- with this wrapping. Forgetting to do the wrapping currently
- means a crash at an assertion when the wrapping would be helpful
- to keep temporaries from being wasted -- see ffecom_push_tempvar. */
-
/* Include files. */
#include "proj.h"
ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token,
const char *msg);
-static void ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar);
+static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
+ tree itersvar);
static void ffeste_io_call_ (tree call, bool do_check);
+static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
static tree ffeste_io_dofio_ (ffebld expr);
static tree ffeste_io_dolio_ (ffebld expr);
static tree ffeste_io_douio_ (ffebld expr);
static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
bool have_end, ffestvFormat format,
ffestpFile *format_spec);
-static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
+static tree ffeste_io_inlist_ (bool have_err,
+ ffestpFile *unit_spec,
+ ffestpFile *file_spec,
+ ffestpFile *exist_spec,
+ ffestpFile *open_spec,
+ ffestpFile *number_spec,
+ ffestpFile *named_spec,
+ ffestpFile *name_spec,
+ ffestpFile *access_spec,
+ ffestpFile *sequential_spec,
+ ffestpFile *direct_spec,
+ ffestpFile *form_spec,
+ ffestpFile *formatted_spec,
+ ffestpFile *unformatted_spec,
+ ffestpFile *recl_spec,
+ ffestpFile *nextrec_spec,
+ ffestpFile *blank_spec);
static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
ffestpFile *file_spec,
ffestpFile *stat_spec,
|| ffeste_statelet_ == FFESTE_stateletITEM_); \
ffeste_statelet_ = FFESTE_stateletSIMPLE_
-#define ffeste_f2c_charnolenspec_(Spec,Exp,Init) \
+#define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
do \
{ \
- if (Spec->kw_or_val_present) \
- Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&ignore); \
+ if ((Spec)->kw_or_val_present) \
+ Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
else \
Exp = null_pointer_node; \
- if (TREE_CONSTANT(Exp)) \
- { \
+ if (Exp) \
Init = Exp; \
- Exp = NULL_TREE; \
- } \
else \
{ \
- Init = null_pointer_node; \
- constantp = FALSE; \
+ Init = null_pointer_node; \
+ constantp = FALSE; \
} \
} while(0)
-#define ffeste_f2c_charspec_(Spec,Exp,Init,Lenexp,Leninit) \
+#define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
do \
{ \
- if (Spec->kw_or_val_present) \
- Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&Lenexp); \
+ if ((Spec)->kw_or_val_present) \
+ Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
else \
{ \
- Exp = null_pointer_node; \
- Lenexp = ffecom_f2c_ftnlen_zero_node; \
+ Exp = null_pointer_node; \
+ Lenexp = ffecom_f2c_ftnlen_zero_node; \
} \
- if (TREE_CONSTANT(Exp)) \
- { \
+ if (Exp) \
Init = Exp; \
- Exp = NULL_TREE; \
+ else \
+ { \
+ Init = null_pointer_node; \
+ constantp = FALSE; \
} \
+ if (Lenexp) \
+ Leninit = Lenexp; \
else \
{ \
- Init = null_pointer_node; \
- constantp = FALSE; \
+ Leninit = ffecom_f2c_ftnlen_zero_node; \
+ constantp = FALSE; \
} \
- if ((Lenexp != NULL_TREE) && TREE_CONSTANT(Lenexp)) \
+ } while(0)
+
+#define ffeste_f2c_init_flag_(Flag,Init) \
+ do \
+ { \
+ Init = convert (ffecom_f2c_flag_type_node, \
+ (Flag) ? integer_one_node : integer_zero_node); \
+ } while(0)
+
+#define ffeste_f2c_init_format_(Exp,Init,Spec) \
+ do \
+ { \
+ Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
+ if (Exp) \
+ Init = Exp; \
+ else \
{ \
- Leninit = Lenexp; \
- Lenexp = NULL_TREE; \
+ Init = null_pointer_node; \
+ constantp = FALSE; \
} \
+ } while(0)
+
+#define ffeste_f2c_init_int_(Exp,Init,Spec) \
+ do \
+ { \
+ if ((Spec)->kw_or_val_present) \
+ Exp = ffecom_const_expr ((Spec)->u.expr); \
+ else \
+ Exp = ffecom_integer_zero_node; \
+ if (Exp) \
+ Init = Exp; \
else \
{ \
- Leninit = ffecom_f2c_ftnlen_zero_node; \
- constantp = FALSE; \
+ Init = ffecom_integer_zero_node; \
+ constantp = FALSE; \
} \
} while(0)
-#define ffeste_f2c_exp_(Field,Exp) \
+#define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
do \
{ \
- if (Exp != NULL_TREE) \
+ if ((Spec)->kw_or_val_present) \
+ Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
+ else \
+ Exp = null_pointer_node; \
+ if (Exp) \
+ Init = Exp; \
+ else \
{ \
- Exp = ffecom_modify(void_type_node,ffecom_2(COMPONENT_REF, \
- TREE_TYPE(Field),t,Field),Exp); \
- expand_expr_stmt(Exp); \
+ Init = null_pointer_node; \
+ constantp = FALSE; \
} \
} while(0)
-#define ffeste_f2c_init_(Init) \
+#define ffeste_f2c_init_next_(Init) \
do \
{ \
- TREE_CHAIN(initn) = build_tree_list((field = TREE_CHAIN(field)),Init); \
- initn = TREE_CHAIN(initn); \
+ TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
+ (Init)); \
+ initn = TREE_CHAIN(initn); \
} while(0)
-#define ffeste_f2c_flagspec_(Flag,Init) \
- do { Init = convert (ffecom_f2c_flag_type_node, \
- Flag ? integer_one_node : integer_zero_node); } \
- while(0)
+#define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
+ do \
+ { \
+ if (! (Exp)) \
+ ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
+ } while(0)
-#define ffeste_f2c_intspec_(Spec,Exp,Init) \
+#define ffeste_f2c_prepare_char_(Spec,Exp) \
do \
{ \
- if (Spec->kw_or_val_present) \
- Exp = ffecom_expr(Spec->u.expr); \
- else \
- Exp = ffecom_integer_zero_node; \
- if (TREE_CONSTANT(Exp)) \
+ if (! (Exp)) \
+ ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
+ } while(0)
+
+#define ffeste_f2c_prepare_format_(Spec,Exp) \
+ do \
+ { \
+ if (! (Exp)) \
+ ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
+ } while(0)
+
+#define ffeste_f2c_prepare_int_(Spec,Exp) \
+ do \
+ { \
+ if (! (Exp)) \
+ ffecom_prepare_expr ((Spec)->u.expr); \
+ } while(0)
+
+#define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
+ do \
+ { \
+ if (! (Exp)) \
+ ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
+ } while(0)
+
+#define ffeste_f2c_compile_(Field,Exp) \
+ do \
+ { \
+ tree exz; \
+ if ((Exp)) \
{ \
- Init = Exp; \
- Exp = NULL_TREE; \
+ exz = ffecom_modify (void_type_node, \
+ ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
+ t, (Field)), \
+ (Exp)); \
+ expand_expr_stmt (exz); \
} \
- else \
+ } while(0)
+
+#define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
+ do \
+ { \
+ tree exq; \
+ if (! (Exp)) \
{ \
- Init = ffecom_integer_zero_node; \
- constantp = FALSE; \
+ exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
+ ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
-#define ffeste_f2c_ptrtointspec_(Spec,Exp,Init) \
+#define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
do \
{ \
- if (Spec->kw_or_val_present) \
- Exp = ffecom_ptr_to_expr(Spec->u.expr); \
- else \
- Exp = null_pointer_node; \
- if (TREE_CONSTANT(Exp)) \
+ tree exq = (Exp); \
+ tree lenexq = (Lenexp); \
+ int need_exq = (! exq); \
+ int need_lenexq = (! lenexq); \
+ if (need_exq || need_lenexq) \
{ \
- Init = Exp; \
- Exp = NULL_TREE; \
+ exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
+ if (need_exq) \
+ ffeste_f2c_compile_ ((Field), exq); \
+ if (need_lenexq) \
+ ffeste_f2c_compile_ ((Lenfield), lenexq); \
} \
- else \
+ } while(0)
+
+#define ffeste_f2c_compile_format_(Field,Spec,Exp) \
+ do \
+ { \
+ tree exq; \
+ if (! (Exp)) \
+ { \
+ exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
+ ffeste_f2c_compile_ ((Field), exq); \
+ } \
+ } while(0)
+
+#define ffeste_f2c_compile_int_(Field,Spec,Exp) \
+ do \
+ { \
+ tree exq; \
+ if (! (Exp)) \
+ { \
+ exq = ffecom_expr ((Spec)->u.expr); \
+ ffeste_f2c_compile_ ((Field), exq); \
+ } \
+ } while(0)
+
+#define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
+ do \
+ { \
+ tree exq; \
+ if (! (Exp)) \
{ \
- Init = null_pointer_node; \
- constantp = FALSE; \
+ exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
+ ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
\f
+/* Start a Fortran block. */
+
+#ifdef ENABLE_CHECKING
+
+typedef struct gbe_block
+{
+ struct gbe_block *outer;
+ ffestw block;
+ int lineno;
+ char *input_filename;
+ bool is_stmt;
+} *gbe_block;
+
+gbe_block ffeste_top_block_ = NULL;
+
+static void
+ffeste_start_block_ (ffestw block)
+{
+ gbe_block b = xmalloc (sizeof (*b));
+
+ b->outer = ffeste_top_block_;
+ b->block = block;
+ b->lineno = lineno;
+ b->input_filename = input_filename;
+ b->is_stmt = FALSE;
+
+ ffeste_top_block_ = b;
+
+ ffecom_start_compstmt ();
+}
+
+/* End a Fortran block. */
+
+static void
+ffeste_end_block_ (ffestw block)
+{
+ gbe_block b = ffeste_top_block_;
+
+ assert (b);
+ assert (! b->is_stmt);
+ assert (b->block == block);
+ assert (! b->is_stmt);
+
+ ffeste_top_block_ = b->outer;
+
+ free (b);
+
+ clear_momentary ();
+
+ ffecom_end_compstmt ();
+}
+
+/* Start a Fortran statement.
+
+ Starts a back-end block, so temporaries can be managed, clean-ups
+ properly handled, etc. Nesting of statements *is* allowed -- the
+ handling of I/O items, even implied-DO I/O lists, within a READ,
+ PRINT, or WRITE statement is one example. */
+
+static void
+ffeste_start_stmt_(void)
+{
+ gbe_block b = xmalloc (sizeof (*b));
+
+ b->outer = ffeste_top_block_;
+ b->block = NULL;
+ b->lineno = lineno;
+ b->input_filename = input_filename;
+ b->is_stmt = TRUE;
+
+ ffeste_top_block_ = b;
+
+ ffecom_start_compstmt ();
+}
+
+/* End a Fortran statement. */
+
+static void
+ffeste_end_stmt_(void)
+{
+ gbe_block b = ffeste_top_block_;
+
+ assert (b);
+ assert (b->is_stmt);
+
+ ffeste_top_block_ = b->outer;
+
+ free (b);
+
+ clear_momentary ();
+
+ ffecom_end_compstmt ();
+}
+
+#else /* ! defined (ENABLE_CHECKING) */
+
+#define ffeste_start_block_(b) ffecom_start_compstmt ()
+#define ffeste_end_block_(b) \
+ do \
+ { \
+ clear_momentary (); \
+ ffecom_end_compstmt (); \
+ } while(0)
+#define ffeste_start_stmt_() ffeste_start_block_(NULL)
+#define ffeste_end_stmt_() ffeste_end_block_(NULL)
+
+#endif /* ! defined (ENABLE_CHECKING) */
/* Begin an iterative DO loop. Pass the block to start if applicable.
tree tincr;
tree tincr_saved;
tree niters;
+ struct nesting *expanded_loop;
- push_momentary (); /* Want to save these throughout the loop. */
+ /* Want to have tvar, tincr, and niters for the whole loop body. */
- tvar = ffecom_expr_rw (var);
+ if (block)
+ ffeste_start_block_ (block);
+ else
+ ffeste_start_stmt_ ();
+
+ niters = ffecom_make_tempvar (block ? "do" : "impdo",
+ ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+
+ ffecom_prepare_expr (incr);
+ ffecom_prepare_expr_rw (NULL_TREE, var);
+
+ ffecom_prepare_end ();
+
+ tvar = ffecom_expr_rw (NULL_TREE, var);
tincr = ffecom_expr (incr);
if (TREE_CODE (tvar) == ERROR_MARK
|| TREE_CODE (tincr) == ERROR_MARK)
{
if (block)
- ffestw_set_do_tvar (block, error_mark_node);
+ {
+ ffeste_end_block_ (block);
+ ffestw_set_do_tvar (block, error_mark_node);
+ }
else
- *xtvar = error_mark_node;
- pop_momentary ();
+ {
+ ffeste_end_stmt_ ();
+ *xtvar = error_mark_node;
+ }
return;
}
tincr_saved = ffecom_save_tree (tincr);
- push_momentary (); /* Want to discard the rest after the loop. */
+ preserve_momentary ();
+
+ /* Want to have tstart, tend for just this statement. */
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (start);
+ ffecom_prepare_expr (end);
+
+ ffecom_prepare_end ();
tstart = ffecom_expr (start);
tend = ffecom_expr (end);
if (TREE_CODE (tstart) == ERROR_MARK
|| TREE_CODE (tend) == ERROR_MARK)
{
+ ffeste_end_stmt_ ();
+
if (block)
- ffestw_set_do_tvar (block, error_mark_node);
+ {
+ ffeste_end_block_ (block);
+ ffestw_set_do_tvar (block, error_mark_node);
+ }
else
- *xtvar = error_mark_node;
- pop_momentary ();
- pop_momentary ();
+ {
+ ffeste_end_stmt_ ();
+ *xtvar = error_mark_node;
+ }
return;
}
- { /* For warnings only, nothing else
- happens here. */
+ /* For warnings only, nothing else happens here. */
+ {
tree try;
- if (!ffe_is_onetrip ())
+ if (! ffe_is_onetrip ())
{
try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
tend,
tend,
tstart);
- if (!ffe_is_onetrip ())
+ if (! ffe_is_onetrip ())
{
expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
expr,
expr = convert (ffecom_integer_type_node, expr);
#endif
- niters = ffecom_push_tempvar (TREE_TYPE (expr),
- FFETARGET_charactersizeNONE, -1, FALSE);
+ assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
+ == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
+
expr = ffecom_modify (void_type_node, niters, expr);
expand_expr_stmt (expr);
expr = ffecom_modify (void_type_node, tvar, tstart);
expand_expr_stmt (expr);
- if (block == NULL)
- expand_start_loop_continue_elsewhere (0);
- else
- ffestw_set_do_hook (block,
- expand_start_loop_continue_elsewhere (1));
+ ffeste_end_stmt_ ();
+
+ expanded_loop = expand_start_loop_continue_elsewhere (!! block);
+ if (block)
+ ffestw_set_do_hook (block, expanded_loop);
- if (!ffe_is_onetrip ())
+ if (! ffe_is_onetrip ())
{
expr = ffecom_truth_value
(ffecom_2 (GE_EXPR, integer_type_node,
expand_exit_loop_if_false (0, expr);
}
- clear_momentary (); /* Discard the above now that we're done with
- DO stmt. */
-
- if (block == NULL)
- {
- *xtvar = tvar;
- *xtincr = tincr_saved;
- *xitersvar = niters;
- }
- else
+ if (block)
{
ffestw_set_do_tvar (block, tvar);
ffestw_set_do_incr_saved (block, tincr_saved);
ffestw_set_do_count_var (block, niters);
}
+ else
+ {
+ *xtvar = tvar;
+ *xtincr = tincr_saved;
+ *xitersvar = niters;
+ }
}
#endif
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar)
+ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
{
tree expr;
tree niters = itersvar;
expand_loop_continue_here ();
+ ffeste_start_stmt_ ();
+
if (ffe_is_onetrip ())
{
expr = ffecom_truth_value
tvar,
tincr));
expand_expr_stmt (expr);
- expand_end_loop ();
- ffecom_pop_tempvar (itersvar); /* Free #iters var. */
+ /* Lose the stuff we just built. */
+ ffeste_end_stmt_ ();
- clear_momentary ();
- pop_momentary (); /* Lose the stuff we just built. */
+ expand_end_loop ();
- clear_momentary ();
- pop_momentary (); /* Lose the tvar and incr_saved trees. */
+ /* Lose the tvar and incr_saved trees. */
+ if (block)
+ ffeste_end_block_ (block);
+ else
+ ffeste_end_stmt_ ();
}
-
#endif
-/* ffeste_io_call_ -- Generate call to run-time I/O routine
- tree callexpr = build(CALL_EXPR,...);
- ffeste_io_call_(callexpr,TRUE);
-
- Sets TREE_SIDE_EFFECTS(callexpr) = 1. If ffeste_io_iostat_ is not
- NULL_TREE, replaces callexpr with "iostat = callexpr;". Expands the
- result. If ffeste_io_abort_ is not NULL_TREE and the second argument
- is TRUE, generates "if (iostat != 0) goto ffeste_io_abort_;". */
+/* Generate call to run-time I/O routine. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
TREE_SIDE_EFFECTS (call) = 1;
if (ffeste_io_iostat_ != NULL_TREE)
- {
- call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
- ffeste_io_iostat_, call);
- }
+ call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
+ ffeste_io_iostat_, call);
expand_expr_stmt (call);
- if (!do_check
- || (ffeste_io_abort_ == NULL_TREE)
- || (TREE_CODE (ffeste_io_abort_) == ERROR_MARK))
+ if (! do_check
+ || ffeste_io_abort_ == NULL_TREE
+ || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
return;
/* Generate optional test. */
expand_goto (ffeste_io_abort_);
expand_end_cond ();
}
+#endif
+
+/* Handle implied-DO in I/O list.
+
+ Expands code to start up the DO loop. Then for each item in the
+ DO loop, handles appropriately (possibly including recursively calling
+ itself). Then expands code to end the DO loop. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
+{
+ ffebld var = ffebld_head (ffebld_right (impdo));
+ ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
+ ffebld end = ffebld_head (ffebld_trail (ffebld_trail
+ (ffebld_right (impdo))));
+ ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
+ (ffebld_trail (ffebld_right (impdo)))));
+ ffebld list;
+ ffebld item;
+ tree tvar;
+ tree tincr;
+ tree titervar;
+
+ if (incr == NULL)
+ {
+ incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
+ ffebld_set_info (incr, ffeinfo_new
+ (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT,
+ 0,
+ FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT,
+ FFETARGET_charactersizeNONE));
+ }
+
+ /* Start the DO loop. */
+
+ start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
+ FFEEXPR_contextLET);
+ end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
+ FFEEXPR_contextLET);
+ incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
+ FFEEXPR_contextLET);
+
+ ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
+ start, impdo_token,
+ end, impdo_token,
+ incr, impdo_token,
+ "Implied DO loop");
+
+ /* Handle the list of items. */
+
+ for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
+ {
+ item = ffebld_head (list);
+ if (item == NULL)
+ continue;
+
+ /* Strip parens off items such as in "READ *,(A)". This is really a bug
+ in the user's code, but I've been told lots of code does this. */
+ while (ffebld_op (item) == FFEBLD_opPAREN)
+ item = ffebld_left (item);
+
+ if (ffebld_op (item) == FFEBLD_opANY)
+ continue;
+ if (ffebld_op (item) == FFEBLD_opIMPDO)
+ ffeste_io_impdo_ (item, impdo_token);
+ else
+ {
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_arg_ptr_to_expr (item);
+
+ ffecom_prepare_end ();
+
+ ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
+
+ ffeste_end_stmt_ ();
+ }
+ }
+
+ /* Generate end of implied-do construct. */
+
+ ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
+}
#endif
-/* ffeste_io_dofio_ -- Generate call to do_fio for formatted I/O item
- ffebld expr;
- tree call;
- call = ffeste_io_dofio_(expr);
+/* I/O driver for formatted I/O item (do_fio)
Returns a tree for a CALL_EXPR to the do_fio function, which handles
a formatted I/O list item, along with the appropriate arguments for
else
is_complex = FALSE;
- ffecom_push_calltemps ();
-
variable = ffecom_arg_ptr_to_expr (expr, &size);
if ((variable == error_mark_node)
|| (size == error_mark_node))
- {
- ffecom_pop_calltemps ();
- return error_mark_node;
- }
+ return error_mark_node;
if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
- if ((ffeinfo_rank (ffebld_info (expr)) == 0)
- || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
- num_elements = is_complex ? ffecom_f2c_ftnlen_two_node
- : ffecom_f2c_ftnlen_one_node;
+ if (ffeinfo_rank (ffebld_info (expr)) == 0
+ || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
+ num_elements
+ = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
else
{
num_elements = size_binop (CEIL_DIV_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
+ size);
num_elements = size_binop (CEIL_DIV_EXPR,
num_elements,
size_int (TYPE_PRECISION
TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
- ffecom_pop_calltemps ();
-
- return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist);
+ return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
}
#endif
-/* ffeste_io_dolio_ -- Generate call to do_lio for list-directed I/O item
-
- ffebld expr;
- tree call;
- call = ffeste_io_dolio_(expr);
+/* I/O driver for list-directed I/O item (do_lio)
Returns a tree for a CALL_EXPR to the do_lio function, which handles
a list-directed I/O list item, along with the appropriate arguments for
|| (kt == FFEINFO_kindtypeANY))
return error_mark_node;
- ffecom_push_calltemps ();
-
tc = ffecom_f2c_typecode (bt, kt);
assert (tc != -1);
type_id = build_int_2 (tc, 0);
if ((type_id == error_mark_node)
|| (variable == error_mark_node)
|| (size == error_mark_node))
- {
- ffecom_pop_calltemps ();
- return error_mark_node;
- }
+ return error_mark_node;
if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
- if ((ffeinfo_rank (ffebld_info (expr)) == 0)
- || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
+ if (ffeinfo_rank (ffebld_info (expr)) == 0
+ || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
num_elements = ffecom_integer_one_node;
else
{
num_elements = size_binop (CEIL_DIV_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
+ size);
num_elements = size_binop (CEIL_DIV_EXPR,
num_elements,
size_int (TYPE_PRECISION
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
= build_tree_list (NULL_TREE, size);
- ffecom_pop_calltemps ();
-
- return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist);
+ return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
}
#endif
-/* ffeste_io_douio_ -- Generate call to do_uio for unformatted I/O item
-
- ffebld expr;
- tree call;
- call = ffeste_io_douio_(expr);
+/* I/O driver for unformatted I/O item (do_uio)
Returns a tree for a CALL_EXPR to the do_uio function, which handles
an unformatted I/O list item, along with the appropriate arguments for
else
is_complex = FALSE;
- ffecom_push_calltemps ();
-
variable = ffecom_arg_ptr_to_expr (expr, &size);
if ((variable == error_mark_node)
|| (size == error_mark_node))
- {
- ffecom_pop_calltemps ();
- return error_mark_node;
- }
+ return error_mark_node;
if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
- if ((ffeinfo_rank (ffebld_info (expr)) == 0)
- || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
- num_elements = is_complex ? ffecom_f2c_ftnlen_two_node
- : ffecom_f2c_ftnlen_one_node;
+ if (ffeinfo_rank (ffebld_info (expr)) == 0
+ || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
+ num_elements
+ = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
else
{
num_elements = size_binop (CEIL_DIV_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
+ size);
num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
size_int (TYPE_PRECISION
(char_type_node)));
TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
- ffecom_pop_calltemps ();
-
- return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist);
+ return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
}
#endif
-/* ffeste_io_ialist_ -- Make arglist with ptr to B/E/R control list
-
- tree arglist;
- arglist = ffeste_io_ialist_(...);
+/* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
Returns a tree suitable as an argument list containing a pointer to
a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_alist_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
+
+ ffeste_f2c_init_flag_ (have_err, errinit);
switch (unit)
{
case FFESTV_unitNONE:
case FFESTV_unitASTERISK:
unitinit = build_int_2 (unit_dflt, 0);
- unitexp = NULL_TREE;
+ unitexp = unitinit;
break;
case FFESTV_unitINTEXPR:
- unitexp = ffecom_expr (unit_expr);
- if (TREE_CONSTANT (unitexp))
- {
- unitinit = unitexp;
- unitexp = NULL_TREE;
- }
+ unitexp = ffecom_const_expr (unit_expr);
+ if (unitexp)
+ unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
default:
assert ("bad unit spec" == NULL);
- unitexp = NULL_TREE;
unitinit = ffecom_integer_zero_node;
+ unitexp = unitinit;
break;
}
inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
+ ffeste_f2c_init_next_ (unitinit);
inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
+ /* Prepare run-time expressions. */
+
+ if (! unitexp)
+ ffecom_prepare_expr (unit_expr);
+
+ ffecom_prepare_end ();
+
+ /* Now evaluate run-time expressions as needed. */
+
+ if (! unitexp)
+ {
+ unitexp = ffecom_expr (unit_expr);
+ ffeste_f2c_compile_ (unitfield, unitexp);
+ }
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
}
#endif
-/* ffeste_io_cilist_ -- Make arglist with ptr to external I/O control list
-
- tree arglist;
- arglist = ffeste_io_cilist_(...);
+/* Make arglist with ptr to external-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
- an external-file I/O control list. First, generates that control
+ an external-I/O control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_cilist_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
+
+ ffeste_f2c_init_flag_ (have_err, errinit);
switch (unit)
{
case FFESTV_unitNONE:
case FFESTV_unitASTERISK:
unitinit = build_int_2 (unit_dflt, 0);
- unitexp = NULL_TREE;
+ unitexp = unitinit;
break;
case FFESTV_unitINTEXPR:
- unitexp = ffecom_expr (unit_expr);
- if (TREE_CONSTANT (unitexp))
- {
- unitinit = unitexp;
- unitexp = NULL_TREE;
- }
+ unitexp = ffecom_const_expr (unit_expr);
+ if (unitexp)
+ unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
default:
assert ("bad unit spec" == NULL);
- unitexp = NULL_TREE;
unitinit = ffecom_integer_zero_node;
+ unitexp = unitinit;
break;
}
{
case FFESTV_formatNONE:
formatinit = null_pointer_node;
- formatexp = NULL_TREE;
+ formatexp = formatinit;
break;
case FFESTV_formatLABEL:
- formatexp = NULL_TREE;
+ formatexp = error_mark_node;
formatinit = ffecom_lookup_label (format_spec->u.label);
if ((formatinit == NULL_TREE)
|| (TREE_CODE (formatinit) == ERROR_MARK))
break;
case FFESTV_formatCHAREXPR:
- formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
- if (TREE_CONSTANT (formatexp))
- {
- formatinit = formatexp;
- formatexp = NULL_TREE;
- }
+ formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
+ if (formatexp)
+ formatinit = formatexp;
else
{
formatinit = null_pointer_node;
case FFESTV_formatASTERISK:
formatinit = null_pointer_node;
- formatexp = NULL_TREE;
+ formatexp = formatinit;
break;
case FFESTV_formatINTEXPR:
case FFESTV_formatNAMELIST:
formatinit = ffecom_expr (format_spec->u.expr);
- formatexp = NULL_TREE;
+ formatexp = formatinit;
break;
default:
assert ("bad format spec" == NULL);
- formatexp = NULL_TREE;
formatinit = integer_zero_node;
+ formatexp = formatinit;
break;
}
- ffeste_f2c_flagspec_ (have_end, endinit);
+ ffeste_f2c_init_flag_ (have_end, endinit);
if (rec)
- recexp = ffecom_expr (rec_expr);
+ recexp = ffecom_const_expr (rec_expr);
else
recexp = ffecom_integer_zero_node;
- if (TREE_CONSTANT (recexp))
- {
- recinit = recexp;
- recexp = NULL_TREE;
- }
+ if (recexp)
+ recinit = recexp;
else
{
recinit = ffecom_integer_zero_node;
inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
- ffeste_f2c_init_ (endinit);
- ffeste_f2c_init_ (formatinit);
- ffeste_f2c_init_ (recinit);
+ ffeste_f2c_init_next_ (unitinit);
+ ffeste_f2c_init_next_ (endinit);
+ ffeste_f2c_init_next_ (formatinit);
+ ffeste_f2c_init_next_ (recinit);
inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
- ffeste_f2c_exp_ (formatfield, formatexp);
- ffeste_f2c_exp_ (recfield, recexp);
+ /* Prepare run-time expressions. */
+
+ if (! unitexp)
+ ffecom_prepare_expr (unit_expr);
+
+ if (! formatexp)
+ ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
+
+ if (! recexp)
+ ffecom_prepare_expr (rec_expr);
+
+ ffecom_prepare_end ();
+
+ /* Now evaluate run-time expressions as needed. */
+
+ if (! unitexp)
+ {
+ unitexp = ffecom_expr (unit_expr);
+ ffeste_f2c_compile_ (unitfield, unitexp);
+ }
+
+ if (! formatexp)
+ {
+ formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
+ ffeste_f2c_compile_ (formatfield, formatexp);
+ }
+ else if (format == FFESTV_formatINTEXPR)
+ ffeste_f2c_compile_ (formatfield, formatexp);
+
+ if (! recexp)
+ {
+ recexp = ffecom_expr (rec_expr);
+ ffeste_f2c_compile_ (recfield, recexp);
+ }
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
}
#endif
-/* ffeste_io_cllist_ -- Make arglist with ptr to CLOSE control list
-
- tree arglist;
- arglist = ffeste_io_cllist_(...);
+/* Make arglist with ptr to CLOSE control list.
Returns a tree suitable as an argument list containing a pointer to
a CLOSE-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_close_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
+
+ ffeste_f2c_init_flag_ (have_err, errinit);
- unitexp = ffecom_expr (unit_expr);
- if (TREE_CONSTANT (unitexp))
- {
- unitinit = unitexp;
- unitexp = NULL_TREE;
- }
+ unitexp = ffecom_const_expr (unit_expr);
+ if (unitexp)
+ unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
- ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
+ ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
- ffeste_f2c_init_ (statinit);
+ ffeste_f2c_init_next_ (unitinit);
+ ffeste_f2c_init_next_ (statinit);
inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
- ffeste_f2c_exp_ (statfield, statexp);
+ /* Prepare run-time expressions. */
+
+ if (! unitexp)
+ ffecom_prepare_expr (unit_expr);
+
+ if (! statexp)
+ ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
+
+ ffecom_prepare_end ();
+
+ /* Now evaluate run-time expressions as needed. */
+
+ if (! unitexp)
+ {
+ unitexp = ffecom_expr (unit_expr);
+ ffeste_f2c_compile_ (unitfield, unitexp);
+ }
+
+ ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
}
#endif
-/* ffeste_io_icilist_ -- Make arglist with ptr to internal I/O control list
-
- tree arglist;
- arglist = ffeste_io_icilist_(...);
+/* Make arglist with ptr to internal-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
- an internal-file I/O control list. First, generates that control
+ an internal-I/O control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_icilist_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
- unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
- if ((ffeinfo_rank (ffebld_info (unit_expr)) == 0)
- || (TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
- unitnumexp = ffecom_integer_one_node;
- else
- {
- unitnumexp = size_binop (CEIL_DIV_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), unitlenexp);
- unitnumexp = size_binop (CEIL_DIV_EXPR,
- unitnumexp, size_int (TYPE_PRECISION
- (char_type_node)));
- }
- if (TREE_CONSTANT (unitexp))
- {
- unitinit = unitexp;
- unitexp = NULL_TREE;
- }
+ ffeste_f2c_init_flag_ (have_err, errinit);
+
+ unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
+ if (unitexp)
+ unitinit = unitexp;
else
{
unitinit = null_pointer_node;
constantp = FALSE;
}
- if ((unitlenexp != NULL_TREE) && TREE_CONSTANT (unitlenexp))
- {
- unitleninit = unitlenexp;
- unitlenexp = NULL_TREE;
- }
+ if (unitlenexp)
+ unitleninit = unitlenexp;
else
{
unitleninit = ffecom_integer_zero_node;
constantp = FALSE;
}
- if (TREE_CONSTANT (unitnumexp))
+
+ /* Now see if we can fully initialize the number of elements, or
+ if we have to compute that at run time. */
+ if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
+ || (unitexp
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
{
- unitnuminit = unitnumexp;
- unitnumexp = NULL_TREE;
+ /* Not an array, so just one element. */
+ unitnuminit = ffecom_integer_one_node;
+ unitnumexp = unitnuminit;
+ }
+ else if (unitexp && unitlenexp)
+ {
+ /* An array, but all the info is constant, so compute now. */
+ unitnuminit = size_binop (CEIL_DIV_EXPR,
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))),
+ unitlenexp);
+ unitnuminit = size_binop (CEIL_DIV_EXPR,
+ unitnuminit,
+ size_int (TYPE_PRECISION
+ (char_type_node)));
+ unitnumexp = unitnuminit;
}
else
{
+ /* Put off computing until run time. */
unitnuminit = ffecom_integer_zero_node;
+ unitnumexp = NULL_TREE;
constantp = FALSE;
}
{
case FFESTV_formatNONE:
formatinit = null_pointer_node;
- formatexp = NULL_TREE;
+ formatexp = formatinit;
break;
case FFESTV_formatLABEL:
- formatexp = NULL_TREE;
+ formatexp = error_mark_node;
formatinit = ffecom_lookup_label (format_spec->u.label);
if ((formatinit == NULL_TREE)
|| (TREE_CODE (formatinit) == ERROR_MARK))
break;
case FFESTV_formatCHAREXPR:
- formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
- if (TREE_CONSTANT (formatexp))
- {
- formatinit = formatexp;
- formatexp = NULL_TREE;
- }
- else
- {
- formatinit = null_pointer_node;
- constantp = FALSE;
- }
+ ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
break;
case FFESTV_formatASTERISK:
formatinit = null_pointer_node;
- formatexp = NULL_TREE;
+ formatexp = formatinit;
break;
case FFESTV_formatINTEXPR:
default:
assert ("bad format spec" == NULL);
- formatexp = NULL_TREE;
formatinit = ffecom_integer_zero_node;
+ formatexp = formatinit;
break;
}
- ffeste_f2c_flagspec_ (have_end, endinit);
+ ffeste_f2c_init_flag_ (have_end, endinit);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
- ffeste_f2c_init_ (endinit);
- ffeste_f2c_init_ (formatinit);
- ffeste_f2c_init_ (unitleninit);
- ffeste_f2c_init_ (unitnuminit);
+ ffeste_f2c_init_next_ (unitinit);
+ ffeste_f2c_init_next_ (endinit);
+ ffeste_f2c_init_next_ (formatinit);
+ ffeste_f2c_init_next_ (unitleninit);
+ ffeste_f2c_init_next_ (unitnuminit);
inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
- ffeste_f2c_exp_ (formatfield, formatexp);
- ffeste_f2c_exp_ (unitlenfield, unitlenexp);
- ffeste_f2c_exp_ (unitnumfield, unitnumexp);
-
- ttype = build_pointer_type (TREE_TYPE (t));
- t = ffecom_1 (ADDR_EXPR, ttype, t);
-
- t = build_tree_list (NULL_TREE, t);
-
- return t;
-}
+ /* Prepare run-time expressions. */
-#endif
-/* ffeste_io_impdo_ -- Handle implied-DO in I/O list
+ if (! unitexp)
+ ffecom_prepare_arg_ptr_to_expr (unit_expr);
- ffebld expr;
- ffeste_io_impdo_(expr);
+ ffeste_f2c_prepare_format_ (format_spec, formatexp);
- Expands code to start up the DO loop. Then for each item in the
- DO loop, handles appropriately (possibly including recursively calling
- itself). Then expands code to end the DO loop. */
+ ffecom_prepare_end ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
-{
- ffebld var = ffebld_head (ffebld_right (impdo));
- ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
- ffebld end = ffebld_head (ffebld_trail (ffebld_trail
- (ffebld_right (impdo))));
- ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
- (ffebld_trail (ffebld_right (impdo)))));
- ffebld list; /* Used for list of items in left part of
- impdo. */
- ffebld item; /* I/O item from head of given list. */
- tree tvar;
- tree tincr;
- tree titervar;
+ /* Now evaluate run-time expressions as needed. */
- if (incr == NULL)
+ if (! unitexp || ! unitlenexp)
{
- incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (incr, ffeinfo_new
- (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
+ int need_unitexp = (! unitexp);
+ int need_unitlenexp = (! unitlenexp);
+
+ unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
+ if (need_unitexp)
+ ffeste_f2c_compile_ (unitfield, unitexp);
+ if (need_unitlenexp)
+ ffeste_f2c_compile_ (unitlenfield, unitlenexp);
}
- /* Start the DO loop. */
-
- start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
- FFEEXPR_contextLET);
- end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
- FFEEXPR_contextLET);
- incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
- FFEEXPR_contextLET);
-
- ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
- start, impdo_token,
- end, impdo_token,
- incr, impdo_token,
- "Implied DO loop");
-
- /* Handle the list of items. */
-
- for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
+ if (! unitnumexp
+ && unitexp != error_mark_node
+ && unitlenexp != error_mark_node)
{
- item = ffebld_head (list);
- if (item == NULL)
- continue;
- while (ffebld_op (item) == FFEBLD_opPAREN)
- item = ffebld_left (item);
- if (ffebld_op (item) == FFEBLD_opANY)
- continue;
- if (ffebld_op (item) == FFEBLD_opIMPDO)
- ffeste_io_impdo_ (item, impdo_token);
- else
- ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
- clear_momentary ();
+ unitnumexp = size_binop (CEIL_DIV_EXPR,
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))),
+ unitlenexp);
+ unitnumexp = size_binop (CEIL_DIV_EXPR,
+ unitnumexp,
+ size_int (TYPE_PRECISION
+ (char_type_node)));
+ ffeste_f2c_compile_ (unitnumfield, unitnumexp);
}
- /* Generate end of implied-do construct. */
+ if (format == FFESTV_formatINTEXPR)
+ ffeste_f2c_compile_ (formatfield, formatexp);
+ else
+ ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
- ffeste_end_iterdo_ (tvar, tincr, titervar);
-}
+ ttype = build_pointer_type (TREE_TYPE (t));
+ t = ffecom_1 (ADDR_EXPR, ttype, t);
+
+ t = build_tree_list (NULL_TREE, t);
+ return t;
+}
#endif
-/* ffeste_io_inlist_ -- Make arglist with ptr to INQUIRE control list
- tree arglist;
- arglist = ffeste_io_inlist_(...);
+/* Make arglist with ptr to INQUIRE control list
Returns a tree suitable as an argument list containing a pointer to
an INQUIRE-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_inquire_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
- ffeste_f2c_intspec_ (unit_spec, unitexp, unitinit);
- ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
- ffeste_f2c_ptrtointspec_ (exist_spec, existexp, existinit);
- ffeste_f2c_ptrtointspec_ (open_spec, openexp, openinit);
- ffeste_f2c_ptrtointspec_ (number_spec, numberexp, numberinit);
- ffeste_f2c_ptrtointspec_ (named_spec, namedexp, namedinit);
- ffeste_f2c_charspec_ (name_spec, nameexp, nameinit, namelenexp, nameleninit);
- ffeste_f2c_charspec_ (access_spec, accessexp, accessinit, accesslenexp,
- accessleninit);
- ffeste_f2c_charspec_ (sequential_spec, sequentialexp, sequentialinit,
- sequentiallenexp, sequentialleninit);
- ffeste_f2c_charspec_ (direct_spec, directexp, directinit, directlenexp,
- directleninit);
- ffeste_f2c_charspec_ (form_spec, formexp, forminit, formlenexp, formleninit);
- ffeste_f2c_charspec_ (formatted_spec, formattedexp, formattedinit,
- formattedlenexp, formattedleninit);
- ffeste_f2c_charspec_ (unformatted_spec, unformattedexp, unformattedinit,
- unformattedlenexp, unformattedleninit);
- ffeste_f2c_ptrtointspec_ (recl_spec, reclexp, reclinit);
- ffeste_f2c_ptrtointspec_ (nextrec_spec, nextrecexp, nextrecinit);
- ffeste_f2c_charspec_ (blank_spec, blankexp, blankinit, blanklenexp,
- blankleninit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
+
+ ffeste_f2c_init_flag_ (have_err, errinit);
+ ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
+ ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
+ file_spec);
+ ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
+ ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
+ ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
+ ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
+ ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
+ name_spec);
+ ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
+ accessleninit, access_spec);
+ ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
+ sequentialleninit, sequential_spec);
+ ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
+ directleninit, direct_spec);
+ ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
+ form_spec);
+ ffeste_f2c_init_char_ (formattedexp, formattedinit,
+ formattedlenexp, formattedleninit, formatted_spec);
+ ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
+ unformattedleninit, unformatted_spec);
+ ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
+ ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
+ ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
+ blankleninit, blank_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
- ffeste_f2c_init_ (fileinit);
- ffeste_f2c_init_ (fileleninit);
- ffeste_f2c_init_ (existinit);
- ffeste_f2c_init_ (openinit);
- ffeste_f2c_init_ (numberinit);
- ffeste_f2c_init_ (namedinit);
- ffeste_f2c_init_ (nameinit);
- ffeste_f2c_init_ (nameleninit);
- ffeste_f2c_init_ (accessinit);
- ffeste_f2c_init_ (accessleninit);
- ffeste_f2c_init_ (sequentialinit);
- ffeste_f2c_init_ (sequentialleninit);
- ffeste_f2c_init_ (directinit);
- ffeste_f2c_init_ (directleninit);
- ffeste_f2c_init_ (forminit);
- ffeste_f2c_init_ (formleninit);
- ffeste_f2c_init_ (formattedinit);
- ffeste_f2c_init_ (formattedleninit);
- ffeste_f2c_init_ (unformattedinit);
- ffeste_f2c_init_ (unformattedleninit);
- ffeste_f2c_init_ (reclinit);
- ffeste_f2c_init_ (nextrecinit);
- ffeste_f2c_init_ (blankinit);
- ffeste_f2c_init_ (blankleninit);
+ ffeste_f2c_init_next_ (unitinit);
+ ffeste_f2c_init_next_ (fileinit);
+ ffeste_f2c_init_next_ (fileleninit);
+ ffeste_f2c_init_next_ (existinit);
+ ffeste_f2c_init_next_ (openinit);
+ ffeste_f2c_init_next_ (numberinit);
+ ffeste_f2c_init_next_ (namedinit);
+ ffeste_f2c_init_next_ (nameinit);
+ ffeste_f2c_init_next_ (nameleninit);
+ ffeste_f2c_init_next_ (accessinit);
+ ffeste_f2c_init_next_ (accessleninit);
+ ffeste_f2c_init_next_ (sequentialinit);
+ ffeste_f2c_init_next_ (sequentialleninit);
+ ffeste_f2c_init_next_ (directinit);
+ ffeste_f2c_init_next_ (directleninit);
+ ffeste_f2c_init_next_ (forminit);
+ ffeste_f2c_init_next_ (formleninit);
+ ffeste_f2c_init_next_ (formattedinit);
+ ffeste_f2c_init_next_ (formattedleninit);
+ ffeste_f2c_init_next_ (unformattedinit);
+ ffeste_f2c_init_next_ (unformattedleninit);
+ ffeste_f2c_init_next_ (reclinit);
+ ffeste_f2c_init_next_ (nextrecinit);
+ ffeste_f2c_init_next_ (blankinit);
+ ffeste_f2c_init_next_ (blankleninit);
inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
- ffeste_f2c_exp_ (filefield, fileexp);
- ffeste_f2c_exp_ (filelenfield, filelenexp);
- ffeste_f2c_exp_ (existfield, existexp);
- ffeste_f2c_exp_ (openfield, openexp);
- ffeste_f2c_exp_ (numberfield, numberexp);
- ffeste_f2c_exp_ (namedfield, namedexp);
- ffeste_f2c_exp_ (namefield, nameexp);
- ffeste_f2c_exp_ (namelenfield, namelenexp);
- ffeste_f2c_exp_ (accessfield, accessexp);
- ffeste_f2c_exp_ (accesslenfield, accesslenexp);
- ffeste_f2c_exp_ (sequentialfield, sequentialexp);
- ffeste_f2c_exp_ (sequentiallenfield, sequentiallenexp);
- ffeste_f2c_exp_ (directfield, directexp);
- ffeste_f2c_exp_ (directlenfield, directlenexp);
- ffeste_f2c_exp_ (formfield, formexp);
- ffeste_f2c_exp_ (formlenfield, formlenexp);
- ffeste_f2c_exp_ (formattedfield, formattedexp);
- ffeste_f2c_exp_ (formattedlenfield, formattedlenexp);
- ffeste_f2c_exp_ (unformattedfield, unformattedexp);
- ffeste_f2c_exp_ (unformattedlenfield, unformattedlenexp);
- ffeste_f2c_exp_ (reclfield, reclexp);
- ffeste_f2c_exp_ (nextrecfield, nextrecexp);
- ffeste_f2c_exp_ (blankfield, blankexp);
- ffeste_f2c_exp_ (blanklenfield, blanklenexp);
+ /* Prepare run-time expressions. */
+
+ ffeste_f2c_prepare_int_ (unit_spec, unitexp);
+ ffeste_f2c_prepare_char_ (file_spec, fileexp);
+ ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
+ ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
+ ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
+ ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
+ ffeste_f2c_prepare_char_ (name_spec, nameexp);
+ ffeste_f2c_prepare_char_ (access_spec, accessexp);
+ ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
+ ffeste_f2c_prepare_char_ (direct_spec, directexp);
+ ffeste_f2c_prepare_char_ (form_spec, formexp);
+ ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
+ ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
+ ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
+ ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
+ ffeste_f2c_prepare_char_ (blank_spec, blankexp);
+
+ ffecom_prepare_end ();
+
+ /* Now evaluate run-time expressions as needed. */
+
+ ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
+ ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
+ fileexp, filelenexp);
+ ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
+ ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
+ ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
+ ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
+ ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
+ namelenexp);
+ ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
+ accessexp, accesslenexp);
+ ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
+ sequential_spec, sequentialexp,
+ sequentiallenexp);
+ ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
+ directexp, directlenexp);
+ ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
+ formlenexp);
+ ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
+ formattedexp, formattedlenexp);
+ ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
+ unformatted_spec, unformattedexp,
+ unformattedlenexp);
+ ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
+ ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
+ ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
+ blanklenexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
}
#endif
-/* ffeste_io_olist_ -- Make arglist with ptr to OPEN control list
-
- tree arglist;
- arglist = ffeste_io_olist_(...);
+/* Make arglist with ptr to OPEN control list
Returns a tree suitable as an argument list containing a pointer to
an OPEN-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
- that are needed as specified by the arguments to this function. */
+ that are needed as specified by the arguments to this function.
+
+ Must ensure that all expressions are prepared before being evaluated,
+ for any whose evaluation might result in the generation of temporaries.
+
+ Note that this means this function causes a transition, within the
+ current block being code-generated via the back end, from the
+ declaration of variables (temporaries) to the expanding of expressions,
+ statements, etc. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
f2c_open_struct = ref;
}
- ffeste_f2c_flagspec_ (have_err, errinit);
+ /* Try to do as much compile-time initialization of the structure
+ as possible, to save run time. */
- unitexp = ffecom_expr (unit_expr);
- if (TREE_CONSTANT (unitexp))
- {
- unitinit = unitexp;
- unitexp = NULL_TREE;
- }
+ ffeste_f2c_init_flag_ (have_err, errinit);
+
+ unitexp = ffecom_const_expr (unit_expr);
+ if (unitexp)
+ unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
- ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
- ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
- ffeste_f2c_charnolenspec_ (access_spec, accessexp, accessinit);
- ffeste_f2c_charnolenspec_ (form_spec, formexp, forminit);
- ffeste_f2c_intspec_ (recl_spec, reclexp, reclinit);
- ffeste_f2c_charnolenspec_ (blank_spec, blankexp, blankinit);
+ ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
+ file_spec);
+ ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
+ ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
+ ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
+ ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
+ ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
initn = inits;
- ffeste_f2c_init_ (unitinit);
- ffeste_f2c_init_ (fileinit);
- ffeste_f2c_init_ (fileleninit);
- ffeste_f2c_init_ (statinit);
- ffeste_f2c_init_ (accessinit);
- ffeste_f2c_init_ (forminit);
- ffeste_f2c_init_ (reclinit);
- ffeste_f2c_init_ (blankinit);
+ ffeste_f2c_init_next_ (unitinit);
+ ffeste_f2c_init_next_ (fileinit);
+ ffeste_f2c_init_next_ (fileleninit);
+ ffeste_f2c_init_next_ (statinit);
+ ffeste_f2c_init_next_ (accessinit);
+ ffeste_f2c_init_next_ (forminit);
+ ffeste_f2c_init_next_ (reclinit);
+ ffeste_f2c_init_next_ (blankinit);
inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
resume_momentary (yes);
- ffeste_f2c_exp_ (unitfield, unitexp);
- ffeste_f2c_exp_ (filefield, fileexp);
- ffeste_f2c_exp_ (filelenfield, filelenexp);
- ffeste_f2c_exp_ (statfield, statexp);
- ffeste_f2c_exp_ (accessfield, accessexp);
- ffeste_f2c_exp_ (formfield, formexp);
- ffeste_f2c_exp_ (reclfield, reclexp);
- ffeste_f2c_exp_ (blankfield, blankexp);
+ /* Prepare run-time expressions. */
+
+ if (! unitexp)
+ ffecom_prepare_expr (unit_expr);
+
+ ffeste_f2c_prepare_char_ (file_spec, fileexp);
+ ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
+ ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
+ ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
+ ffeste_f2c_prepare_int_ (recl_spec, reclexp);
+ ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
+
+ ffecom_prepare_end ();
+
+ /* Now evaluate run-time expressions as needed. */
+
+ if (! unitexp)
+ {
+ unitexp = ffecom_expr (unit_expr);
+ ffeste_f2c_compile_ (unitfield, unitexp);
+ }
+
+ ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
+ filelenexp);
+ ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
+ ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
+ ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
+ ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
+ ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
}
#endif
-/* ffeste_subr_file_ -- Display file-statement specifier
-
- ffeste_subr_file_(&specifier); */
+/* Display file-statement specifier. */
#if FFECOM_targetCURRENT == FFECOM_targetFFE
static void
}
#endif
-/* ffeste_subr_beru_ -- Generate code for BACKSPACE/ENDFILE/REWIND
-
- ffeste_subr_beru_(FFECOM_gfrtFBACK); */
+/* Generate code for BACKSPACE/ENDFILE/REWIND. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
bool iostat;
bool errl;
-#define specified(something) (info->beru_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
- /* Do the real work. */
+#define specified(something) (info->beru_spec[something].kw_or_val_present)
iostat = specified (FFESTP_beruixIOSTAT);
errl = specified (FFESTP_beruixERR);
+#undef specified
+
/* ~~For now, we assume the unit number is specified and is not ASTERISK,
because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
without any unit specifier. f2c, however, supports the former
ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
ffeste_R919 and company, and they will want to pass that same value to
this function, and that argument will replace the constant _unitINTEXPR_
- in the call below. Right now, the default unit number, 6, is ignored. */
+ in the call below. Right now, the default unit number, 6, is ignored. */
- ffecom_push_calltemps ();
-
- alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
- info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
+ ffeste_start_stmt_ ();
if (errl)
- { /* ERR= */
+ {
+ /* Have ERR= specification. */
+
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
ffeste_io_abort_is_temp_ = FALSE;
}
else
- { /* no ERR= */
+ {
+ /* No ERR= specification. */
+
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= */
+ {
+ /* Have no IOSTAT= but have ERR=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, or ERR= */
+ {
+ /* No IOSTAT= or ERR= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
+ info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
+
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (rt, alist),
- !ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
assert (ffeste_io_err_ == NULL_TREE);
}
- /* If we've got a temp iostat, pop the temp. */
-
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
-
- ffecom_pop_calltemps ();
-
-#undef specified
-
- clear_momentary ();
+ ffeste_end_stmt_ ();
}
-
#endif
-/* ffeste_do -- End of statement following DO-term-stmt etc
- ffeste_do(TRUE);
+/* END DO statement
Also invoked by _labeldef_branch_finish_ (or, in cases
of errors, other _labeldef_ functions) when the label definition is
for a DO-target (LOOPEND) label, once per matching/outstanding DO
- block on the stack. These cases invoke this function with ok==TRUE, so
- only forced stack popping (via ffeste_eof_()) invokes it with ok==FALSE. */
+ block on the stack. */
void
ffeste_do (ffestw block)
fputs ("+ END_DO\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
if (ffestw_do_tvar (block) == 0)
- expand_end_loop (); /* DO WHILE and just DO. */
+ {
+ expand_end_loop (); /* DO WHILE and just DO. */
+
+ ffeste_end_block_ (block);
+ }
else
- ffeste_end_iterdo_ (ffestw_do_tvar (block),
+ ffeste_end_iterdo_ (block,
+ ffestw_do_tvar (block),
ffestw_do_incr_saved (block),
ffestw_do_count_var (block));
-
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_end_R807 -- End of statement following logical IF
+/* End of statement following logical IF.
- ffeste_end_R807(TRUE);
-
- Applies ONLY to logical IF, not to IF-THEN. For example, does not
- ffelex_token_kill the construct name for an IF-THEN block (the name
- field is invalid for logical IF). ok==TRUE iff statement following
- logical IF (substatement) is valid; else, statement is invalid or
- stack forcibly popped due to ffeste_eof_(). */
+ Applies to *only* logical IF, not to IF-THEN. */
void
ffeste_end_R807 ()
fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
expand_end_cond ();
- clear_momentary ();
+
+ ffeste_end_block_ (NULL);
#else
#error
#endif
}
-/* ffeste_labeldef_branch -- Generate "code" for branch label def
-
- ffeste_labeldef_branch(label); */
+/* Generate "code" for branch label definition. */
void
ffeste_labeldef_branch (ffelab label)
assert (glabel != NULL_TREE);
if (TREE_CODE (glabel) == ERROR_MARK)
return;
+
assert (DECL_INITIAL (glabel) == NULL_TREE);
+
DECL_INITIAL (glabel) = error_mark_node;
DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
+
emit_nop ();
+
expand_label (glabel);
}
#else
#endif
}
-/* ffeste_labeldef_format -- Generate "code" for FORMAT label def
-
- ffeste_labeldef_format(label); */
+/* Generate "code" for FORMAT label definition. */
void
ffeste_labeldef_format (ffelab label)
#endif
}
-/* ffeste_R737A -- Assignment statement outside of WHERE
-
- ffeste_R737A(dest_expr,source_expr); */
+/* Assignment statement (outside of WHERE). */
void
ffeste_R737A (ffebld dest, ffebld source)
fputc ('\n', dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+
+ ffeste_start_stmt_ ();
ffecom_expand_let_stmt (dest, source);
- ffecom_pop_calltemps ();
- clear_momentary ();
+ ffeste_end_stmt_ ();
#else
#error
#endif
}
-/* ffeste_R803 -- Block IF (IF-THEN) statement
-
- ffeste_R803(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
+/* Block IF (IF-THEN) statement. */
void
-ffeste_R803 (ffebld expr)
+ffeste_R803 (ffestw block, ffebld expr)
{
ffeste_check_simple_ ();
ffebld_dump (expr);
fputs (")\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+ {
+ tree temp;
+
+ ffeste_emit_line_note_ ();
- expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
+ ffeste_start_block_ (block);
- ffecom_pop_calltemps ();
- clear_momentary ();
+ temp = ffecom_make_tempvar ("ifthen", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ if (ffecom_prepare_end ())
+ {
+ tree result;
+
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
+
+ expand_expr_stmt (result);
+
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ ffeste_end_stmt_ ();
+
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
+
+ expand_start_cond (temp, 0);
+
+ /* No fake `else' constructs introduced (yet). */
+ ffestw_set_ifthen_fake_else (block, 0);
+ }
#else
#error
#endif
}
-/* ffeste_R804 -- ELSE IF statement
-
- ffeste_R804(expr,expr_token,name_token);
-
- Make sure ffeste_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the else
- of the IF block. */
+/* ELSE IF statement. */
void
-ffeste_R804 (ffebld expr)
+ffeste_R804 (ffestw block, ffebld expr)
{
ffeste_check_simple_ ();
ffebld_dump (expr);
fputs (")\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+ {
+ tree temp;
+
+ ffeste_emit_line_note_ ();
- expand_start_elseif (ffecom_truth_value (ffecom_expr (expr)));
+ /* Since ELSEIF(expr) might require preparations for expr,
+ implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
- ffecom_pop_calltemps ();
- clear_momentary ();
+ expand_start_else ();
+
+ ffeste_start_block_ (block);
+
+ temp = ffecom_make_tempvar ("elseif", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ if (ffecom_prepare_end ())
+ {
+ tree result;
+
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
+
+ expand_expr_stmt (result);
+
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ /* In this case, we could probably have used expand_start_elseif
+ instead, saving the need for a fake `else' construct. But,
+ until it's clear that'd improve performance, it's easier this
+ way, since we have to expand_start_else before we get to this
+ test, given the current design. */
+
+ ffeste_end_stmt_ ();
+
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
+
+ expand_start_cond (temp, 0);
+
+ /* Increment number of fake `else' constructs introduced. */
+ ffestw_set_ifthen_fake_else (block,
+ ffestw_ifthen_fake_else (block) + 1);
+ }
#else
#error
#endif
}
-/* ffeste_R805 -- ELSE statement
-
- ffeste_R805(name_token);
-
- Make sure ffeste_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the ELSE
- of the IF block. */
+/* ELSE statement. */
void
-ffeste_R805 ()
+ffeste_R805 (ffestw block UNUSED)
{
ffeste_check_simple_ ();
fputs ("+ ELSE\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
expand_start_else ();
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R806 -- End an IF-THEN
-
- ffeste_R806(TRUE); */
+/* END IF statement. */
void
-ffeste_R806 ()
+ffeste_R806 (ffestw block)
{
#if FFECOM_targetCURRENT == FFECOM_targetFFE
fputs ("+ END_IF_then\n", dmpout); /* Also see ffeste_shriek_if_. */
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffeste_emit_line_note_ ();
- expand_end_cond ();
- clear_momentary ();
+ {
+ int i = ffestw_ifthen_fake_else (block) + 1;
+
+ ffeste_emit_line_note_ ();
+
+ for (; i; --i)
+ {
+ expand_end_cond ();
+
+ ffeste_end_block_ (block);
+ }
+ }
#else
#error
#endif
}
-/* ffeste_R807 -- Logical IF statement
-
- ffeste_R807(expr,expr_token);
-
- Make sure statement is valid here; implement. */
+/* Logical IF statement. */
void
ffeste_R807 (ffebld expr)
ffebld_dump (expr);
fputs (")\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+ {
+ tree temp;
+
+ ffeste_emit_line_note_ ();
+
+ ffeste_start_block_ (NULL);
+
+ temp = ffecom_make_tempvar ("if", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ if (ffecom_prepare_end ())
+ {
+ tree result;
+
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
+
+ expand_expr_stmt (result);
+
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ ffeste_end_stmt_ ();
- expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
- ffecom_pop_calltemps ();
- clear_momentary ();
+ expand_start_cond (temp, 0);
+ }
#else
#error
#endif
}
-/* ffeste_R809 -- SELECT CASE statement
-
- ffeste_R809(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
+/* SELECT CASE statement. */
void
ffeste_R809 (ffestw block, ffebld expr)
ffebld_dump (expr);
fputs (")\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffecom_push_calltemps ();
+ ffeste_emit_line_note_ ();
- {
- tree texpr;
+ ffeste_start_block_ (block);
- ffeste_emit_line_note_ ();
+ if ((expr == NULL)
+ || (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeANY))
+ ffestw_set_select_texpr (block, error_mark_node);
+ else if (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeCHARACTER)
+ {
+ /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
- if ((expr == NULL)
- || (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeANY))
- {
- ffestw_set_select_texpr (block, error_mark_node);
- clear_momentary ();
- }
- else
- {
- texpr = ffecom_expr (expr);
- if (ffeinfo_basictype (ffebld_info (expr))
- != FFEINFO_basictypeCHARACTER)
- {
- expand_start_case (1, texpr, TREE_TYPE (texpr),
- "SELECT CASE statement");
- ffestw_set_select_texpr (block, texpr);
- ffestw_set_select_break (block, FALSE);
- push_momentary ();
- }
- else
- {
- ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
- FFEBAD_severityFATAL);
- ffebad_here (0, ffestw_line (block), ffestw_col (block));
- ffebad_finish ();
- ffestw_set_select_texpr (block, error_mark_node);
- }
- }
- }
+ ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
+ FFEBAD_severityFATAL);
+ ffebad_here (0, ffestw_line (block), ffestw_col (block));
+ ffebad_finish ();
+ ffestw_set_select_texpr (block, error_mark_node);
+ }
+ else
+ {
+ tree result;
+ tree texpr;
+
+ result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
+ ffeinfo_size (ffebld_info (expr)),
+ -1);
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ ffecom_prepare_end ();
+
+ texpr = ffecom_expr (expr);
+
+ assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
+ == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
- ffecom_pop_calltemps ();
+ texpr = ffecom_modify (void_type_node,
+ result,
+ texpr);
+ expand_expr_stmt (texpr);
+
+ ffeste_end_stmt_ ();
+
+ expand_start_case (1, result, TREE_TYPE (result),
+ "SELECT CASE statement");
+ ffestw_set_select_texpr (block, texpr);
+ ffestw_set_select_break (block, FALSE);
+ }
#else
#error
#endif
}
-/* ffeste_R810 -- CASE statement
-
- ffeste_R810(case_value_range_list,name);
+/* CASE statement.
If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
the start of the first_stmt list in the select object at the top of
{
tree texprlow;
tree texprhigh;
- tree tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+ tree tlabel;
int pushok;
tree duplicate;
ffeste_emit_line_note_ ();
- if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
- {
- clear_momentary ();
- return;
- }
+ if (ffestw_select_texpr (block) == error_mark_node)
+ return;
+
+ /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
+
+ tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
if (ffestw_select_break (block))
expand_exit_something ();
while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
clear_momentary ();
- } /* ~~~handle character, character*1 */
+ }
#else
#error
#endif
}
-/* ffeste_R811 -- End a SELECT
-
- ffeste_R811(TRUE); */
+/* END SELECT statement. */
void
ffeste_R811 (ffestw block)
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
- if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
- {
- clear_momentary ();
- return;
- }
+ /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
- expand_end_case (ffestw_select_texpr (block));
- pop_momentary ();
- clear_momentary (); /* ~~~handle character and character*1 */
+ if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
+ expand_end_case (ffestw_select_texpr (block));
+
+ ffeste_end_block_ (block);
#else
#error
#endif
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
{
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
-
- /* Start the DO loop. */
ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
var,
end, end_token,
incr, incr_token,
"Iterative DO loop");
-
- ffecom_pop_calltemps ();
}
#else
#error
#endif
}
-/* ffeste_R819B -- DO WHILE statement
-
- ffeste_R819B(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
+/* DO WHILE statement. */
void
ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
fputs (")\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
{
+ tree result;
+
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
- ffestw_set_do_hook (block, expand_start_loop (1));
- ffestw_set_do_tvar (block, 0); /* Means DO WHILE vs. iter DO. */
- if (expr != NULL)
- expand_exit_loop_if_false (0, ffecom_truth_value (ffecom_expr (expr)));
+ ffeste_start_block_ (block);
- ffecom_pop_calltemps ();
- clear_momentary ();
+ if (expr)
+ {
+ result = ffecom_make_tempvar ("dowhile", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ ffecom_prepare_end ();
+
+ result = ffecom_modify (void_type_node,
+ result,
+ ffecom_truth_value (ffecom_expr (expr)));
+ expand_expr_stmt (result);
+
+ ffeste_end_stmt_ ();
+
+ ffestw_set_do_hook (block, expand_start_loop (1));
+ expand_exit_loop_if_false (0, result);
+ }
+ else
+ ffestw_set_do_hook (block, expand_start_loop (1));
+
+ ffestw_set_do_tvar (block, NULL_TREE);
}
#else
#error
#endif
}
-/* ffeste_R825 -- END DO statement
-
- ffeste_R825(name_token);
+/* END DO statement.
- Make sure ffeste_kind_ identifies a DO block. If not
- NULL, make sure name_token gives the correct name. Do whatever
- is specific to seeing END DO with a DO-target label definition on it,
- where the END DO is really treated as a CONTINUE (i.e. generate th
- same code you would for CONTINUE). ffeste_do handles the actual
- generation of end-loop code. */
+ This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
+ CONTINUE (except that it has to have a label that is the target of
+ one or more iterative DO statement), not the Fortran-90 structured
+ END DO, which is handled elsewhere, as is the actual mechanism of
+ ending an iterative DO statement, even one that ends at a label. */
void
ffeste_R825 ()
fputs ("+ END_DO_sugar\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
emit_nop ();
#else
#error
#endif
}
-/* ffeste_R834 -- CYCLE statement
-
- ffeste_R834(name_token);
-
- Handle a CYCLE within a loop. */
+/* CYCLE statement. */
void
ffeste_R834 (ffestw block)
fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
expand_continue_loop (ffestw_do_hook (block));
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R835 -- EXIT statement
-
- ffeste_R835(name_token);
-
- Handle a EXIT within a loop. */
+/* EXIT statement. */
void
ffeste_R835 (ffestw block)
fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
expand_exit_loop (ffestw_do_hook (block));
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R836 -- GOTO statement
-
- ffeste_R836(label);
-
- Make sure label_token identifies a valid label for a GOTO. Update
- that label's info to indicate it is the target of a GOTO. */
+/* GOTO statement. */
void
ffeste_R836 (ffelab label)
tree glabel;
ffeste_emit_line_note_ ();
+
glabel = ffecom_lookup_label (label);
if ((glabel != NULL_TREE)
&& (TREE_CODE (glabel) != ERROR_MARK))
{
- TREE_USED (glabel) = 1;
expand_goto (glabel);
- clear_momentary ();
+ TREE_USED (glabel) = 1;
}
}
#else
#endif
}
-/* ffeste_R837 -- Computed GOTO statement
-
- ffeste_R837(labels,count,expr);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
+/* Computed GOTO statement. */
void
ffeste_R837 (ffelab *labels, int count, ffebld expr)
tree duplicate;
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ ffecom_prepare_end ();
texpr = ffecom_expr (expr);
+
expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
- push_momentary (); /* In case of lots of labels, keep clearing
- them out. */
+
for (i = 0; i < count; ++i)
{
value = build_int_2 (i + 1, 0);
pushok = pushcase (value, convert, tlabel, &duplicate);
assert (pushok == 0);
+
tlabel = ffecom_lookup_label (labels[i]);
if ((tlabel == NULL_TREE)
|| (TREE_CODE (tlabel) == ERROR_MARK))
continue;
- TREE_USED (tlabel) = 1;
+
expand_goto (tlabel);
- clear_momentary ();
+ TREE_USED (tlabel) = 1;
}
- pop_momentary ();
expand_end_case (texpr);
- ffecom_pop_calltemps ();
- clear_momentary ();
+ ffeste_end_stmt_ ();
}
#else
#error
#endif
}
-/* ffeste_R838 -- ASSIGN statement
-
- ffeste_R838(label_token,target_variable,target_token);
-
- Make sure label_token identifies a valid label for an assignment. Update
- that label's info to indicate it is the source of an assignment. Update
- target_variable's info to indicate it is the target the assignment of that
- label. */
+/* ASSIGN statement. */
void
ffeste_R838 (ffelab label, ffebld target)
tree target_tree;
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
label_tree = ffecom_lookup_label (label);
if ((label_tree != NULL_TREE)
build_pointer_type (void_type_node),
label_tree);
TREE_CONSTANT (label_tree) = 1;
+
target_tree = ffecom_expr_assign_w (target);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
error ("ASSIGN to variable that is too small");
+
label_tree = convert (TREE_TYPE (target_tree), label_tree);
+
expr_tree = ffecom_modify (void_type_node,
target_tree,
label_tree);
expand_expr_stmt (expr_tree);
+
clear_momentary ();
}
-
- ffecom_pop_calltemps ();
}
#else
#error
#endif
}
-/* ffeste_R839 -- Assigned GOTO statement
-
- ffeste_R839(target,target_token,label_list);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
+/* Assigned GOTO statement. */
void
ffeste_R839 (ffebld target)
tree t;
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
t = ffecom_expr_assign (target);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
error ("ASSIGNed GOTO target variable is too small");
+
expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
- ffecom_pop_calltemps ();
clear_momentary ();
}
#else
#endif
}
-/* ffeste_R840 -- Arithmetic IF statement
-
- ffeste_R840(expr,expr_token,neg,zero,pos);
-
- Make sure the labels are valid; implement. */
+/* Arithmetic IF statement. */
void
ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
tree gpos = ffecom_lookup_label (pos);
tree texpr;
+ ffeste_emit_line_note_ ();
+
if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
return;
if ((TREE_CODE (gneg) == ERROR_MARK)
|| (TREE_CODE (gpos) == ERROR_MARK))
return;
- ffecom_push_calltemps ();
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_expr (expr);
+
+ ffecom_prepare_end ();
if (neg == zero)
{
if (neg == pos)
expand_goto (gzero);
else
- { /* IF (expr.LE.0) THEN GOTO neg/zero ELSE
- GOTO pos. */
+ {
+ /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
texpr = ffecom_expr (expr);
texpr = ffecom_2 (LE_EXPR, integer_type_node,
texpr,
}
}
else if (neg == pos)
- { /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO
- zero. */
+ {
+ /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
texpr = ffecom_expr (expr);
texpr = ffecom_2 (NE_EXPR, integer_type_node,
texpr,
expand_end_cond ();
}
else if (zero == pos)
- { /* IF (expr.GE.0) THEN GOTO zero/pos ELSE
- GOTO neg. */
+ {
+ /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
texpr = ffecom_expr (expr);
texpr = ffecom_2 (GE_EXPR, integer_type_node,
texpr,
expand_end_cond ();
}
else
- { /* Use a SAVE_EXPR in combo with:
- IF (expr.LT.0) THEN GOTO neg
- ELSEIF (expr.GT.0) THEN GOTO pos
- ELSE GOTO zero. */
+ {
+ /* Use a SAVE_EXPR in combo with:
+ IF (expr.LT.0) THEN GOTO neg
+ ELSEIF (expr.GT.0) THEN GOTO pos
+ ELSE GOTO zero. */
tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
texpr = ffecom_2 (LT_EXPR, integer_type_node,
expand_goto (gzero);
expand_end_cond ();
}
- ffeste_emit_line_note_ ();
- ffecom_pop_calltemps ();
- clear_momentary ();
+ ffeste_end_stmt_ ();
}
#else
#error
#endif
}
-/* ffeste_R841 -- CONTINUE statement
-
- ffeste_R841(); */
+/* CONTINUE statement. */
void
ffeste_R841 ()
fputs ("+ CONTINUE\n", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
+
emit_nop ();
#else
#error
#endif
}
-/* ffeste_R842 -- STOP statement
-
- ffeste_R842(expr); */
+/* STOP statement. */
void
ffeste_R842 (ffebld expr)
ffelexToken msg;
ffeste_emit_line_note_ ();
+
if ((expr == NULL)
|| (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeANY))
== FFEINFO_kindtypeCHARACTERDEFAULT);
}
- ffecom_push_calltemps ();
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
+
callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
- ffecom_pop_calltemps ();
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
TREE_SIDE_EFFECTS (callit) = 1;
+
expand_expr_stmt (callit);
+
clear_momentary ();
}
#else
#endif
}
-/* ffeste_R843 -- PAUSE statement
-
- ffeste_R843(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
+/* PAUSE statement. */
void
ffeste_R843 (ffebld expr)
ffelexToken msg;
ffeste_emit_line_note_ ();
+
if ((expr == NULL)
|| (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeANY))
== FFEINFO_kindtypeCHARACTERDEFAULT);
}
- ffecom_push_calltemps ();
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
+
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
- ffecom_pop_calltemps ();
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
TREE_SIDE_EFFECTS (callit) = 1;
+
expand_expr_stmt (callit);
+
clear_momentary ();
}
#if 0 /* Old approach for phantom g77 run-time
tree callit;
ffeste_emit_line_note_ ();
+
if (expr == NULL)
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE);
+ callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE);
else if (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeINTEGER)
- {
- ffecom_push_calltemps ();
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
- ffecom_pop_calltemps ();
- }
+ callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
+ else if (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeCHARACTER)
+ callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
else
- {
- if (ffeinfo_basictype (ffebld_info (expr))
- != FFEINFO_basictypeCHARACTER)
- break;
- ffecom_push_calltemps ();
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
- ffecom_pop_calltemps ();
- }
+ abort ();
TREE_SIDE_EFFECTS (callit) = 1;
+
expand_expr_stmt (callit);
+
clear_momentary ();
}
#endif
#endif
}
-/* ffeste_R904 -- OPEN statement
-
- ffeste_R904();
-
- Make sure an OPEN is valid in the current context, and implement it. */
+/* OPEN statement. */
void
ffeste_R904 (ffestpOpenStmt *info)
bool iostat;
bool errl;
-#define specified(something) (info->open_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
+#define specified(something) (info->open_spec[something].kw_or_val_present)
+
iostat = specified (FFESTP_openixIOSTAT);
errl = specified (FFESTP_openixERR);
- ffecom_push_calltemps ();
+#undef specified
- args = ffeste_io_olist_ (errl || iostat,
- info->open_spec[FFESTP_openixUNIT].u.expr,
- &info->open_spec[FFESTP_openixFILE],
- &info->open_spec[FFESTP_openixSTATUS],
- &info->open_spec[FFESTP_openixACCESS],
- &info->open_spec[FFESTP_openixFORM],
- &info->open_spec[FFESTP_openixRECL],
- &info->open_spec[FFESTP_openixBLANK]);
+ ffeste_start_stmt_ ();
if (errl)
{
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->open_spec[FFESTP_openixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= */
+ {
+ /* Have no IOSTAT= but have ERR=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("open", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, or ERR= */
+ {
+ /* No IOSTAT= or ERR= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ args = ffeste_io_olist_ (errl || iostat,
+ info->open_spec[FFESTP_openixUNIT].u.expr,
+ &info->open_spec[FFESTP_openixFILE],
+ &info->open_spec[FFESTP_openixSTATUS],
+ &info->open_spec[FFESTP_openixACCESS],
+ &info->open_spec[FFESTP_openixFORM],
+ &info->open_spec[FFESTP_openixRECL],
+ &info->open_spec[FFESTP_openixBLANK]);
+
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args),
- !ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp label, generate its code here. */
+ /* If we've got a temp label, generate its code here. */
if (ffeste_io_abort_is_temp_)
{
assert (ffeste_io_err_ == NULL_TREE);
}
- /* If we've got a temp iostat, pop the temp. */
-
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
-
- ffecom_pop_calltemps ();
-
-#undef specified
+ ffeste_end_stmt_ ();
}
-
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R907 -- CLOSE statement
-
- ffeste_R907();
-
- Make sure a CLOSE is valid in the current context, and implement it. */
+/* CLOSE statement. */
void
ffeste_R907 (ffestpCloseStmt *info)
bool iostat;
bool errl;
-#define specified(something) (info->close_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
+#define specified(something) (info->close_spec[something].kw_or_val_present)
+
iostat = specified (FFESTP_closeixIOSTAT);
errl = specified (FFESTP_closeixERR);
- ffecom_push_calltemps ();
+#undef specified
- args = ffeste_io_cllist_ (errl || iostat,
- info->close_spec[FFESTP_closeixUNIT].u.expr,
- &info->close_spec[FFESTP_closeixSTATUS]);
+ ffeste_start_stmt_ ();
if (errl)
{
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->close_spec[FFESTP_closeixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= */
+ {
+ /* Have no IOSTAT= but have ERR=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("close", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, or ERR= */
+ {
+ /* No IOSTAT= or ERR= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ args = ffeste_io_cllist_ (errl || iostat,
+ info->close_spec[FFESTP_closeixUNIT].u.expr,
+ &info->close_spec[FFESTP_closeixSTATUS]);
+
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args),
- !ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
assert (ffeste_io_err_ == NULL_TREE);
}
- /* If we've got a temp iostat, pop the temp. */
-
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
-
- ffecom_pop_calltemps ();
-
-#undef specified
+ ffeste_end_stmt_ ();
}
-
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R909_start -- READ(...) statement list begin
-
- ffeste_R909_start(FALSE);
-
- Verify that READ is valid here, and begin accepting items in the
- list. */
+/* READ(...) statement -- start. */
void
ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
fputs (") ", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) (info->read_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
- /* Do the real work. */
-
{
ffecomGfrt start;
ffecomGfrt end;
bool endl;
/* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste functio
+ call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "io driver". It
- handles the implied-DO construct, for example. */
+ appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
}
ffeste_io_endgfrt_ = end;
+#define specified(something) (info->read_spec[something].kw_or_val_present)
+
iostat = specified (FFESTP_readixIOSTAT);
errl = specified (FFESTP_readixERR);
endl = specified (FFESTP_readixEND);
- ffecom_push_calltemps ();
+#undef specified
- if (unit == FFESTV_unitCHAREXPR)
- {
- cilist = ffeste_io_icilist_ (errl || iostat,
- info->read_spec[FFESTP_readixUNIT].u.expr,
- endl || iostat, format,
- &info->read_spec[FFESTP_readixFORMAT]);
- }
- else
- {
- cilist = ffeste_io_cilist_ (errl || iostat, unit,
- info->read_spec[FFESTP_readixUNIT].u.expr,
- 5, endl || iostat, format,
- &info->read_spec[FFESTP_readixFORMAT],
- rec,
- info->read_spec[FFESTP_readixREC].u.expr);
- }
+ ffeste_start_stmt_ ();
if (errl)
- { /* ERR= */
+ {
+ /* Have ERR= specification. */
+
ffeste_io_err_
- = ffecom_lookup_label
- (info->read_spec[FFESTP_readixERR].u.label);
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
if (endl)
- { /* ERR= END= */
+ {
+ /* Have both ERR= and END=. Need a temp label to handle both. */
ffeste_io_end_
- = ffecom_lookup_label
- (info->read_spec[FFESTP_readixEND].u.label);
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
ffeste_io_abort_is_temp_ = TRUE;
ffeste_io_abort_ = ffecom_temp_label ();
}
else
- { /* ERR= but no END= */
+ {
+ /* Have ERR= but no END=. */
ffeste_io_end_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
}
}
else
- { /* no ERR= */
+ {
+ /* No ERR= specification. */
+
ffeste_io_err_ = NULL_TREE;
if (endl)
- { /* END= but no ERR= */
+ {
+ /* Have END= but no ERR=. */
ffeste_io_end_
- = ffecom_lookup_label
- (info->read_spec[FFESTP_readixEND].u.label);
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = ffeste_io_end_;
}
else
- { /* no ERR= or END= */
+ {
+ /* Have no ERR= or END=. */
+
ffeste_io_end_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = ffecom_expr
- (info->read_spec[FFESTP_readixIOSTAT].u.expr);
+ ffeste_io_iostat_
+ = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= or END= or both */
+ {
+ /* Have no IOSTAT= but have ERR= and/or END=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("read", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, ERR=, or END= */
+ {
+ /* No IOSTAT=, ERR=, or END= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ if (unit == FFESTV_unitCHAREXPR)
+ cilist = ffeste_io_icilist_ (errl || iostat,
+ info->read_spec[FFESTP_readixUNIT].u.expr,
+ endl || iostat, format,
+ &info->read_spec[FFESTP_readixFORMAT]);
+ else
+ cilist = ffeste_io_cilist_ (errl || iostat, unit,
+ info->read_spec[FFESTP_readixUNIT].u.expr,
+ 5, endl || iostat, format,
+ &info->read_spec[FFESTP_readixFORMAT],
+ rec,
+ info->read_spec[FFESTP_readixREC].u.expr);
+
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
- !ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
-
-#undef specified
-
- push_momentary ();
#else
#error
#endif
}
-/* ffeste_R909_item -- READ statement i/o item
-
- ffeste_R909_item(expr,expr_token);
-
- Implement output-list expression. */
+/* READ statement -- I/O item. */
void
ffeste_R909_item (ffebld expr, ffelexToken expr_token)
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
+
+ /* Strip parens off items such as in "READ *,(A)". This is really a bug
+ in the user's code, but I've been told lots of code does this. */
while (ffebld_op (expr) == FFEBLD_opPAREN)
- expr = ffebld_left (expr); /* "READ *,(A)" -- really a bug in the user's
- code, but I've been told lots of code does
- this (blech)! */
+ expr = ffebld_left (expr);
+
if (ffebld_op (expr) == FFEBLD_opANY)
return;
+
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
- ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
- clear_momentary ();
+ {
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_arg_ptr_to_expr (expr);
+
+ ffecom_prepare_end ();
+
+ ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
+
+ ffeste_end_stmt_ ();
+ }
#else
#error
#endif
}
-/* ffeste_R909_finish -- READ statement list complete
-
- ffeste_R909_finish();
-
- Just wrap up any local activities. */
+/* READ statement -- end. */
void
ffeste_R909_finish ()
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- {
- if (ffeste_io_endgfrt_ != FFECOM_gfrt)
- ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
- !ffeste_io_abort_is_temp_);
-
- clear_momentary ();
- pop_momentary ();
-
- /* If we've got a temp label, generate its code here and have it fan out
- to the END= or ERR= label as appropriate. */
-
- if (ffeste_io_abort_is_temp_)
- {
- DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
- emit_nop ();
- expand_label (ffeste_io_abort_);
+ if (ffeste_io_endgfrt_ != FFECOM_gfrt)
+ ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
+ NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* if (iostat<0) goto end_label; */
+ /* If we've got a temp label, generate its code here and have it fan out
+ to the END= or ERR= label as appropriate. */
- if ((ffeste_io_end_ != NULL_TREE)
- && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
- {
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (LT_EXPR, integer_type_node,
- ffeste_io_iostat_,
- ffecom_integer_zero_node)),
- 0);
- expand_goto (ffeste_io_end_);
- expand_end_cond ();
- }
-
- /* if (iostat>0) goto err_label; */
-
- if ((ffeste_io_err_ != NULL_TREE)
- && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
- {
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (GT_EXPR, integer_type_node,
- ffeste_io_iostat_,
- ffecom_integer_zero_node)),
- 0);
- expand_goto (ffeste_io_err_);
- expand_end_cond ();
- }
+ if (ffeste_io_abort_is_temp_)
+ {
+ DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
+ emit_nop ();
+ expand_label (ffeste_io_abort_);
- }
+ /* "if (iostat<0) goto end_label;". */
- /* If we've got a temp iostat, pop the temp. */
+ if ((ffeste_io_end_ != NULL_TREE)
+ && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
+ {
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (LT_EXPR, integer_type_node,
+ ffeste_io_iostat_,
+ ffecom_integer_zero_node)),
+ 0);
+ expand_goto (ffeste_io_end_);
+ expand_end_cond ();
+ }
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
+ /* "if (iostat>0) goto err_label;". */
- ffecom_pop_calltemps ();
+ if ((ffeste_io_err_ != NULL_TREE)
+ && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
+ {
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (GT_EXPR, integer_type_node,
+ ffeste_io_iostat_,
+ ffecom_integer_zero_node)),
+ 0);
+ expand_goto (ffeste_io_err_);
+ expand_end_cond ();
+ }
+ }
- clear_momentary ();
- }
+ ffeste_end_stmt_ ();
#else
#error
#endif
}
-/* ffeste_R910_start -- WRITE(...) statement list begin
-
- ffeste_R910_start();
-
- Verify that WRITE is valid here, and begin accepting items in the
- list. */
+/* WRITE statement -- start. */
void
ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
fputs (") ", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#define specified(something) (info->write_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
- /* Do the real work. */
-
{
ffecomGfrt start;
ffecomGfrt end;
bool errl;
/* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste functio
+ call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "io driver". It
- handles the implied-DO construct, for example. */
+ appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
}
ffeste_io_endgfrt_ = end;
+#define specified(something) (info->write_spec[something].kw_or_val_present)
+
iostat = specified (FFESTP_writeixIOSTAT);
errl = specified (FFESTP_writeixERR);
- ffecom_push_calltemps ();
+#undef specified
- if (unit == FFESTV_unitCHAREXPR)
- {
- cilist = ffeste_io_icilist_ (errl || iostat,
- info->write_spec[FFESTP_writeixUNIT].u.expr,
- FALSE, format,
- &info->write_spec[FFESTP_writeixFORMAT]);
- }
- else
- {
- cilist = ffeste_io_cilist_ (errl || iostat, unit,
- info->write_spec[FFESTP_writeixUNIT].u.expr,
- 6, FALSE, format,
- &info->write_spec[FFESTP_writeixFORMAT],
- rec,
- info->write_spec[FFESTP_writeixREC].u.expr);
- }
+ ffeste_start_stmt_ ();
ffeste_io_end_ = NULL_TREE;
if (errl)
- { /* ERR= */
+ {
+ /* Have ERR= specification. */
+
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
ffeste_io_abort_is_temp_ = FALSE;
}
else
- { /* no ERR= */
+ {
+ /* No ERR= specification. */
+
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->write_spec[FFESTP_writeixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= */
+ {
+ /* Have no IOSTAT= but have ERR=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("write", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, or ERR= */
+ {
+ /* No IOSTAT= or ERR= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ if (unit == FFESTV_unitCHAREXPR)
+ cilist = ffeste_io_icilist_ (errl || iostat,
+ info->write_spec[FFESTP_writeixUNIT].u.expr,
+ FALSE, format,
+ &info->write_spec[FFESTP_writeixFORMAT]);
+ else
+ cilist = ffeste_io_cilist_ (errl || iostat, unit,
+ info->write_spec[FFESTP_writeixUNIT].u.expr,
+ 6, FALSE, format,
+ &info->write_spec[FFESTP_writeixFORMAT],
+ rec,
+ info->write_spec[FFESTP_writeixREC].u.expr);
+
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
- !ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
-
-#undef specified
-
- push_momentary ();
#else
#error
#endif
}
-/* ffeste_R910_item -- WRITE statement i/o item
-
- ffeste_R910_item(expr,expr_token);
-
- Implement output-list expression. */
+/* WRITE statement -- I/O item. */
void
ffeste_R910_item (ffebld expr, ffelexToken expr_token)
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
+
if (ffebld_op (expr) == FFEBLD_opANY)
return;
+
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
- ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
- clear_momentary ();
+ {
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_arg_ptr_to_expr (expr);
+
+ ffecom_prepare_end ();
+
+ ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
+
+ ffeste_end_stmt_ ();
+ }
#else
#error
#endif
}
-/* ffeste_R910_finish -- WRITE statement list complete
-
- ffeste_R910_finish();
-
- Just wrap up any local activities. */
+/* WRITE statement -- end. */
void
ffeste_R910_finish ()
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- {
- if (ffeste_io_endgfrt_ != FFECOM_gfrt)
- ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
- !ffeste_io_abort_is_temp_);
-
- clear_momentary ();
- pop_momentary ();
-
- /* If we've got a temp label, generate its code here. */
-
- if (ffeste_io_abort_is_temp_)
- {
- DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
- emit_nop ();
- expand_label (ffeste_io_abort_);
-
- assert (ffeste_io_err_ == NULL_TREE);
- }
+ if (ffeste_io_endgfrt_ != FFECOM_gfrt)
+ ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
+ NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp iostat, pop the temp. */
+ /* If we've got a temp label, generate its code here. */
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
+ if (ffeste_io_abort_is_temp_)
+ {
+ DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
+ emit_nop ();
+ expand_label (ffeste_io_abort_);
- ffecom_pop_calltemps ();
+ assert (ffeste_io_err_ == NULL_TREE);
+ }
- clear_momentary ();
- }
+ ffeste_end_stmt_ ();
#else
#error
#endif
}
-/* ffeste_R911_start -- PRINT statement list begin
-
- ffeste_R911_start();
-
- Verify that PRINT is valid here, and begin accepting items in the
- list. */
+/* PRINT statement -- start. */
void
ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
ffeste_emit_line_note_ ();
- /* Do the real work. */
-
{
ffecomGfrt start;
ffecomGfrt end;
tree cilist;
/* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste functio
+ call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "io driver". It
- handles the implied-DO construct, for example. */
+ appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
}
ffeste_io_endgfrt_ = end;
- ffecom_push_calltemps ();
-
- cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
- &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
+ ffeste_start_stmt_ ();
ffeste_io_end_ = NULL_TREE;
ffeste_io_err_ = NULL_TREE;
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
+ /* Now prescan, then convert, all the arguments. */
+
+ cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
+ &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
+
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
- !ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
-
- push_momentary ();
#else
#error
#endif
}
-/* ffeste_R911_item -- PRINT statement i/o item
-
- ffeste_R911_item(expr,expr_token);
-
- Implement output-list expression. */
+/* PRINT statement -- I/O item. */
void
ffeste_R911_item (ffebld expr, ffelexToken expr_token)
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
+
if (ffebld_op (expr) == FFEBLD_opANY)
return;
+
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
- ffeste_io_call_ ((*ffeste_io_driver_) (expr), FALSE);
- clear_momentary ();
+ {
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_arg_ptr_to_expr (expr);
+
+ ffecom_prepare_end ();
+
+ ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
+
+ ffeste_end_stmt_ ();
+ }
#else
#error
#endif
}
-/* ffeste_R911_finish -- PRINT statement list complete
-
- ffeste_R911_finish();
-
- Just wrap up any local activities. */
+/* PRINT statement -- end. */
void
ffeste_R911_finish ()
#if FFECOM_targetCURRENT == FFECOM_targetFFE
fputc ('\n', dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- if (ffeste_io_endgfrt_ != FFECOM_gfrt)
- ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
- FALSE);
- ffecom_pop_calltemps ();
+ if (ffeste_io_endgfrt_ != FFECOM_gfrt)
+ ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
+ NULL_TREE),
+ FALSE);
- clear_momentary ();
- pop_momentary ();
- clear_momentary ();
- }
+ ffeste_end_stmt_ ();
#else
#error
#endif
}
-/* ffeste_R919 -- BACKSPACE statement
-
- ffeste_R919();
-
- Make sure a BACKSPACE is valid in the current context, and implement it. */
+/* BACKSPACE statement. */
void
ffeste_R919 (ffestpBeruStmt *info)
#endif
}
-/* ffeste_R920 -- ENDFILE statement
-
- ffeste_R920();
-
- Make sure a ENDFILE is valid in the current context, and implement it. */
+/* ENDFILE statement. */
void
ffeste_R920 (ffestpBeruStmt *info)
#endif
}
-/* ffeste_R921 -- REWIND statement
-
- ffeste_R921();
-
- Make sure a REWIND is valid in the current context, and implement it. */
+/* REWIND statement. */
void
ffeste_R921 (ffestpBeruStmt *info)
#endif
}
-/* ffeste_R923A -- INQUIRE statement (non-IOLENGTH version)
-
- ffeste_R923A(bool by_file);
-
- Make sure an INQUIRE is valid in the current context, and implement it. */
+/* INQUIRE statement (non-IOLENGTH version). */
void
ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
bool iostat;
bool errl;
-#define specified(something) (info->inquire_spec[something].kw_or_val_present)
-
ffeste_emit_line_note_ ();
+#define specified(something) (info->inquire_spec[something].kw_or_val_present)
+
iostat = specified (FFESTP_inquireixIOSTAT);
errl = specified (FFESTP_inquireixERR);
- ffecom_push_calltemps ();
-
- args = ffeste_io_inlist_ (errl || iostat,
- &info->inquire_spec[FFESTP_inquireixUNIT],
- &info->inquire_spec[FFESTP_inquireixFILE],
- &info->inquire_spec[FFESTP_inquireixEXIST],
- &info->inquire_spec[FFESTP_inquireixOPENED],
- &info->inquire_spec[FFESTP_inquireixNUMBER],
- &info->inquire_spec[FFESTP_inquireixNAMED],
- &info->inquire_spec[FFESTP_inquireixNAME],
- &info->inquire_spec[FFESTP_inquireixACCESS],
- &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
- &info->inquire_spec[FFESTP_inquireixDIRECT],
- &info->inquire_spec[FFESTP_inquireixFORM],
- &info->inquire_spec[FFESTP_inquireixFORMATTED],
- &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
- &info->inquire_spec[FFESTP_inquireixRECL],
- &info->inquire_spec[FFESTP_inquireixNEXTREC],
- &info->inquire_spec[FFESTP_inquireixBLANK]);
+#undef specified
+
+ ffeste_start_stmt_ ();
if (errl)
{
}
if (iostat)
- { /* IOSTAT= */
+ {
+ /* Have IOSTAT= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
- { /* no IOSTAT= but ERR= */
+ {
+ /* Have no IOSTAT= but have ERR=. */
+
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
- = ffecom_push_tempvar (ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1, FALSE);
+ = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
- { /* no IOSTAT=, or ERR= */
+ {
+ /* No IOSTAT= or ERR= specification. */
+
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
+ /* Now prescan, then convert, all the arguments. */
+
+ args
+ = ffeste_io_inlist_ (errl || iostat,
+ &info->inquire_spec[FFESTP_inquireixUNIT],
+ &info->inquire_spec[FFESTP_inquireixFILE],
+ &info->inquire_spec[FFESTP_inquireixEXIST],
+ &info->inquire_spec[FFESTP_inquireixOPENED],
+ &info->inquire_spec[FFESTP_inquireixNUMBER],
+ &info->inquire_spec[FFESTP_inquireixNAMED],
+ &info->inquire_spec[FFESTP_inquireixNAME],
+ &info->inquire_spec[FFESTP_inquireixACCESS],
+ &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
+ &info->inquire_spec[FFESTP_inquireixDIRECT],
+ &info->inquire_spec[FFESTP_inquireixFORM],
+ &info->inquire_spec[FFESTP_inquireixFORMATTED],
+ &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
+ &info->inquire_spec[FFESTP_inquireixRECL],
+ &info->inquire_spec[FFESTP_inquireixNEXTREC],
+ &info->inquire_spec[FFESTP_inquireixBLANK]);
+
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args),
- !ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp label, generate its code here. */
+ /* If we've got a temp label, generate its code here. */
if (ffeste_io_abort_is_temp_)
{
assert (ffeste_io_err_ == NULL_TREE);
}
- /* If we've got a temp iostat, pop the temp. */
-
- if (ffeste_io_iostat_is_temp_)
- ffecom_pop_tempvar (ffeste_io_iostat_);
-
- ffecom_pop_calltemps ();
-
-#undef specified
+ ffeste_end_stmt_ ();
}
-
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
-
- ffeste_R923B_start();
-
- Verify that INQUIRE is valid here, and begin accepting items in the
- list. */
+/* INQUIRE(IOLENGTH=expr) statement -- start. */
void
ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
fputs (") ", dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
+
ffeste_emit_line_note_ ();
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R923B_item -- INQUIRE statement i/o item
-
- ffeste_R923B_item(expr,expr_token);
-
- Implement output-list expression. */
+/* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
void
ffeste_R923B_item (ffebld expr UNUSED)
ffebld_dump (expr);
fputc (',', dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- clear_momentary ();
#else
#error
#endif
}
-/* ffeste_R923B_finish -- INQUIRE statement list complete
-
- ffeste_R923B_finish();
-
- Just wrap up any local activities. */
+/* INQUIRE(IOLENGTH=expr) statement -- end. */
void
ffeste_R923B_finish ()
#if FFECOM_targetCURRENT == FFECOM_targetFFE
fputc ('\n', dmpout);
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- clear_momentary ();
#else
#error
#endif
#endif
}
-/* ffeste_R1103 -- End a PROGRAM
-
- ffeste_R1103(); */
+/* END PROGRAM. */
void
ffeste_R1103 ()
#endif
}
-/* ffeste_R1112 -- End a BLOCK DATA
-
- ffeste_R1112(TRUE); */
+/* END BLOCK DATA. */
void
ffeste_R1112 ()
#endif
}
-/* ffeste_R1212 -- CALL statement
-
- ffeste_R1212(expr,expr_token);
-
- Make sure statement is valid here; implement. */
+/* CALL statement. */
void
ffeste_R1212 (ffebld expr)
else
ffebld_set_trail (prevargs, NULL);
+ ffeste_start_stmt_ ();
+
+ /* No temporaries are actually needed at this level, but we go
+ through the motions anyway, just to be sure in case they do
+ get made. Temporaries needed for arguments should be in the
+ scopes of inner blocks, and if clean-up actions are supported,
+ such as CALL-ing an intrinsic that writes to an argument of one
+ type when a variable of a different type is provided (requiring
+ assignment to the variable from a temporary after the library
+ routine returns), the clean-up must be done by the expression
+ evaluator, generally, to handle alternate returns (which we hope
+ won't ever be supported by intrinsics, but might be a similar
+ issue, such as CALL-ing an F90-style subroutine with an INTERFACE
+ block). That implies the expression evaluator will have to
+ recognize the need for its own temporary anyway, meaning it'll
+ construct a block within the one constructed here. */
+
+ ffecom_prepare_expr (expr);
+
+ ffecom_prepare_end ();
+
if (labels == NULL)
expand_expr_stmt (ffecom_expr (expr));
else
int caseno;
int pushok;
tree duplicate;
+ ffebld label;
texpr = ffecom_expr (expr);
expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
- push_momentary (); /* In case of many labels, keep 'em cleared
- out. */
- for (caseno = 1;
- labels != NULL;
- ++caseno, labels = ffebld_trail (labels))
+
+ for (caseno = 1, label = labels;
+ label != NULL;
+ ++caseno, label = ffebld_trail (label))
{
value = build_int_2 (caseno, 0);
tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
pushok = pushcase (value, convert, tlabel, &duplicate);
assert (pushok == 0);
+
tlabel
- = ffecom_lookup_label (ffebld_labter (ffebld_head (labels)));
+ = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
if ((tlabel == NULL_TREE)
|| (TREE_CODE (tlabel) == ERROR_MARK))
continue;
TREE_USED (tlabel) = 1;
expand_goto (tlabel);
- clear_momentary ();
}
- pop_momentary ();
expand_end_case (texpr);
}
- clear_momentary ();
+
+ ffeste_end_stmt_ ();
}
#else
#error
#endif
}
-/* ffeste_R1221 -- End a FUNCTION
-
- ffeste_R1221(TRUE); */
+/* END FUNCTION. */
void
ffeste_R1221 ()
#endif
}
-/* ffeste_R1225 -- End a SUBROUTINE
-
- ffeste_R1225(TRUE); */
+/* END SUBROUTINE. */
void
ffeste_R1225 ()
#endif
}
-/* ffeste_R1226 -- ENTRY statement
-
- ffeste_R1226(entryname,arglist,ending_token);
-
- Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
- entry point name, and so on. */
+/* ENTRY statement. */
void
ffeste_R1226 (ffesymbol entry)
ffeste_emit_line_note_ ();
+ if (label == error_mark_node)
+ return;
+
DECL_INITIAL (label) = error_mark_node;
emit_nop ();
expand_label (label);
-
- clear_momentary ();
}
#else
#error
#endif
}
-/* ffeste_R1227 -- RETURN statement
-
- ffeste_R1227(expr);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
+/* RETURN statement. */
void
ffeste_R1227 (ffestw block UNUSED, ffebld expr)
tree rtn;
ffeste_emit_line_note_ ();
- ffecom_push_calltemps ();
+
+ ffeste_start_stmt_ ();
+
+ ffecom_prepare_return_expr (expr);
+
+ ffecom_prepare_end ();
rtn = ffecom_return_expr (expr);
expand_null_return ();
}
- ffecom_pop_calltemps ();
- clear_momentary ();
+ ffeste_end_stmt_ ();
}
#else
#error
#endif
}
-/* ffeste_V018_start -- REWRITE(...) statement list begin
-
- ffeste_V018_start();
-
- Verify that REWRITE is valid here, and begin accepting items in the
- list. */
+/* REWRITE statement -- start. */
#if FFESTR_VXT
void
#endif
}
-/* ffeste_V018_item -- REWRITE statement i/o item
-
- ffeste_V018_item(expr,expr_token);
-
- Implement output-list expression. */
+/* REWRITE statement -- I/O item. */
void
ffeste_V018_item (ffebld expr)
#endif
}
-/* ffeste_V018_finish -- REWRITE statement list complete
-
- ffeste_V018_finish();
-
- Just wrap up any local activities. */
+/* REWRITE statement -- end. */
void
ffeste_V018_finish ()
#endif
}
-/* ffeste_V019_start -- ACCEPT statement list begin
-
- ffeste_V019_start();
-
- Verify that ACCEPT is valid here, and begin accepting items in the
- list. */
+/* ACCEPT statement -- start. */
void
ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
#endif
}
-/* ffeste_V019_item -- ACCEPT statement i/o item
-
- ffeste_V019_item(expr,expr_token);
-
- Implement output-list expression. */
+/* ACCEPT statement -- I/O item. */
void
ffeste_V019_item (ffebld expr)
#endif
}
-/* ffeste_V019_finish -- ACCEPT statement list complete
-
- ffeste_V019_finish();
-
- Just wrap up any local activities. */
+/* ACCEPT statement -- end. */
void
ffeste_V019_finish ()
}
#endif
-/* ffeste_V020_start -- TYPE statement list begin
-
- ffeste_V020_start();
-
- Verify that TYPE is valid here, and begin accepting items in the
- list. */
+/* TYPE statement -- start. */
void
ffeste_V020_start (ffestpTypeStmt *info UNUSED,
#endif
}
-/* ffeste_V020_item -- TYPE statement i/o item
-
- ffeste_V020_item(expr,expr_token);
-
- Implement output-list expression. */
+/* TYPE statement -- I/O item. */
void
ffeste_V020_item (ffebld expr UNUSED)
#endif
}
-/* ffeste_V020_finish -- TYPE statement list complete
-
- ffeste_V020_finish();
-
- Just wrap up any local activities. */
+/* TYPE statement -- end. */
void
ffeste_V020_finish ()
#endif
}
-/* ffeste_V021 -- DELETE statement
-
- ffeste_V021();
-
- Make sure a DELETE is valid in the current context, and implement it. */
+/* DELETE statement. */
#if FFESTR_VXT
void
#endif
}
-/* ffeste_V022 -- UNLOCK statement
-
- ffeste_V022();
-
- Make sure a UNLOCK is valid in the current context, and implement it. */
+/* UNLOCK statement. */
void
ffeste_V022 (ffestpBeruStmt *info)
#endif
}
-/* ffeste_V023_start -- ENCODE(...) statement list begin
-
- ffeste_V023_start();
-
- Verify that ENCODE is valid here, and begin accepting items in the
- list. */
+/* ENCODE statement -- start. */
void
ffeste_V023_start (ffestpVxtcodeStmt *info)
#endif
}
-/* ffeste_V023_item -- ENCODE statement i/o item
-
- ffeste_V023_item(expr,expr_token);
-
- Implement output-list expression. */
+/* ENCODE statement -- I/O item. */
void
ffeste_V023_item (ffebld expr)
#endif
}
-/* ffeste_V023_finish -- ENCODE statement list complete
-
- ffeste_V023_finish();
-
- Just wrap up any local activities. */
+/* ENCODE statement -- end. */
void
ffeste_V023_finish ()
#endif
}
-/* ffeste_V024_start -- DECODE(...) statement list begin
-
- ffeste_V024_start();
-
- Verify that DECODE is valid here, and begin accepting items in the
- list. */
+/* DECODE statement -- start. */
void
ffeste_V024_start (ffestpVxtcodeStmt *info)
#endif
}
-/* ffeste_V024_item -- DECODE statement i/o item
-
- ffeste_V024_item(expr,expr_token);
-
- Implement output-list expression. */
+/* DECODE statement -- I/O item. */
void
ffeste_V024_item (ffebld expr)
#endif
}
-/* ffeste_V024_finish -- DECODE statement list complete
-
- ffeste_V024_finish();
-
- Just wrap up any local activities. */
+/* DECODE statement -- end. */
void
ffeste_V024_finish ()
#endif
}
-/* ffeste_V025_start -- DEFINEFILE statement list begin
-
- ffeste_V025_start();
-
- Verify that DEFINEFILE is valid here, and begin accepting items in the
- list. */
+/* DEFINEFILE statement -- start. */
void
ffeste_V025_start ()
#endif
}
-/* ffeste_V025_item -- DEFINE FILE statement item
-
- ffeste_V025_item(u,ut,m,mt,n,nt,asv,asvt);
-
- Implement item. */
+/* DEFINE FILE statement -- item. */
void
ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
#endif
}
-/* ffeste_V025_finish -- DEFINE FILE statement list complete
-
- ffeste_V025_finish();
-
- Just wrap up any local activities. */
+/* DEFINE FILE statement -- end. */
void
ffeste_V025_finish ()
#endif
}
-/* ffeste_V026 -- FIND statement
-
- ffeste_V026();
-
- Make sure a FIND is valid in the current context, and implement it. */
+/* FIND statement. */
void
ffeste_V026 (ffestpFindStmt *info)
}
#endif
+
+#ifdef ENABLE_CHECKING
+void
+ffeste_terminate_2 (void)
+{
+ assert (! ffeste_top_block_);
+}
+#endif
projects / gcc.git / commitdiff