diff options
| -rw-r--r-- | gcc/f/ChangeLog | 109 | ||||
| -rw-r--r-- | gcc/f/bld.c | 9 | ||||
| -rw-r--r-- | gcc/f/bld.h | 19 | ||||
| -rw-r--r-- | gcc/f/com.c | 3306 | ||||
| -rw-r--r-- | gcc/f/com.h | 31 | ||||
| -rw-r--r-- | gcc/f/stc.c | 4 | ||||
| -rw-r--r-- | gcc/f/std.c | 87 | ||||
| -rw-r--r-- | gcc/f/ste.c | 2994 | ||||
| -rw-r--r-- | gcc/f/ste.h | 12 | ||||
| -rw-r--r-- | gcc/f/stw.h | 3 | ||||
| -rw-r--r-- | gcc/f/symbol.c | 1 | ||||
| -rw-r--r-- | gcc/f/symbol.h | 3 | ||||
| -rw-r--r-- | gcc/f/version.c | 2 |
13 files changed, 3844 insertions, 2736 deletions
diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog index 9d2f134..8d07c01 100644 --- a/gcc/f/ChangeLog +++ b/gcc/f/ChangeLog @@ -1,3 +1,112 @@ +Sat Apr 17 13:53:43 1999 Craig Burley <craig@jcb-sc.com> + + Rewrite to use block/scope structure of GBE and to ensure + variables (especially those going on stack/reg) are declared + before executable code generated: + * bld.c (ffebld_new_item, ffebld_new_one, ffebld_new_two): + Support new hooks. + * bld.h (ffebld_item_hook, ffebld_item_set_hook, + ffebld_nonter_hook, ffebld_nonter_set_hook): Ditto. + * bld.h (ffebld_basictype, ffebld_kind, ffebld_kindtype, + ffebld_rank, ffebld_where): New convenience macros (used + by rest of this patch). + * com.c, com.h (ffecom_push_calltemps, ffecom_pop_calltemps, + ffecom_push_tempvar, ffecom_pop_tempvar): Remove temp-var- + handling mechanism. + * com.c (ffecom_call_, ffecom_call_binop_, ffecom_tree_divide_, + ffecom_call_gfrt): Support passing hooks for temp-var info. + (ffecom_expr_power_integer_): Takes opPOWER expression, instead + of its left and right operands, so it can get at the hook. + (ffecom_prepare_let_char_, ffecom_prepare_arg_ptr_to_expr, + ffecom_prepare_end, ffecom_prepare_expr_, ffecom_prepare_expr_rw, + ffecom_prepare_expr_w, ffecom_prepare_return_expr, + ffecom_prepare_ptr_to_expr): New functions supporting expression + pre-scanning. + (bison_rule_compstmt_): Return the tree, as in the CFE. + (delete_block): New function, from CFE. + (kept_level_p): New function, from CFE, modified. + (ffecom_start_compstmt, ffecom_end_compstmt): New functions, + replacing ffecom_start_compstmt_ and ffecom_end_compstmt_ macros, + and they do real work. + (struct binding_level): Add prep_state member. Initialize to 0. + (ffecom_get_invented_identifier): Now takes either or both a + string and an integer, using -1 to denote no integer. + (ffecom_do_entry_): Disallow temp-var generation via expressions + in body of function, since the exprs aren't prescanned. + (ffecom_expr_rw): Now takes destination tree. + (ffecom_expr_w): New function, now used in some places + ffecom_expr_rw had been used. + (ffecom_expr_intrinsic_): Move huge f2c-related comment to bottom + of source file, to avoid annoying problems editing com.c using + Emacs C-mode. + (ffecom_expr_power_integer_): Make a temp var for division, if + necessary. + Handle expanded statement expression as does CFE. + (ffecom_start_progunit_): Disallow temp-var generation in body + of function, since expressions are not prescanned at this level. + (ffecom_sym_transform_): Transform ASSIGN variables as well, + so these are all transformed up front, before code-generation + begins. + (ffecom_arg_ptr_to_const_expr, ffecom_const_expr, + ffecom_ptr_to_const_expr): New functions to transform expressions + only if the results will surely be constants. + (ffecom_arg_ptr_to_expr): Precompute size, for convenience + obtaining temp vars. + (ffecom_expand_let_stmt): Guess at usability of destination + pre-expansion, to provide better prescan preparation (fewer + spurious temp vars). + (ffecom_init_0): Disallow temp-var generation in global scope. + (ffecom_type_expr): New function, returns just the type tree + for the expression. + (start_function): Disallow temp-var generation in parm scope. + (incomplete_type_error): Fix introductory comment. + (poplevel): Update (somewhat) from CFE. + (pushlevel): Update (somewhat) from CFE. + * stc.c (ffestc_R838): Mark ASSIGNed variable as so. + * std.c (ffestd_stmt_pass_, ffestd_R803, ffestd_R804, ffestd_R805, + ffestd_R806): Remember and pass through the ffestw block info + for these (IFTHEN, ELSEIF, ELSE, and ENDIF) statements. + * ste.c (ffeste_end_iterdo_): Now takes ffestw block argument. + (ffeste_io_inlist_): Add prototype. + (ffeste_f2c_*): Macros rewritten, new ones added. + (ffeste_start_block_, ffeste_end_block_, ffeste_start_stmt_, + ffeste_end_stmt_): New macros/functions, depending on whether + checking is enabled, to keep track of symmetry of other ste.c code. + (ffeste_begin_iterdo_, ffeste_end_iterdo_, ffeste_io_impdo_, + ffeste_io_dofio_, ffeste_io_dolio_, ffeste_io_douio_, + ffeste_io_ialist_, ffeste_io_cilist_, ffeste_io_cllist_, + ffeste_icilist_, ffeste_io_inlist_, ffeste_io_olist_, + ffeste_subr_beru_, ffeste_do, ffeste_end_R807, ffeste_R737A, + ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806, ffeste_R807, + ffeste_R809, ffeste_R810, ffeste_R811, ffeste_R819A, ffeste_R819B, + ffeste_R837, ffeste_R838, ffeste_R839, ffeste_R840, ffeste_R904, + ffeste_R907, ffeste_R909_start, ffeste_R909_item, ffeste_R909_finish, + ffeste_R910_start, ffeste_R910_item, ffeste_R910_finish, + ffeste_R911_start, ffeste_R911_item, ffeste_R911_finish, + ffeste_R923A, ffeste_R1212, ffeste_R1227): Prescan/prepare + all pertinent expressions, update to new com.c interface, etc. + (ffeste_io_impdo_): Relocate. + (ffeste_R834, ffeste_R835, ffeste_R836, ffeste_R1226): Don't + bother calling clear_momentary, nothing was generated. + (ffeste_R842, ffeste_R843): Update to new com.c interface. + (ffeste_R1226): Don't try to stuff error_mark_node's DECL_INITIAL. + (ffeste_terminate_2): When checking enabled, make sure all blocks + and statements have been ended. + * ste.h (ffeste_R803, ffeste_R804, ffeste_R805, ffeste_R806): + These now take ffestw block argument. + (ffeste_terminate_2): When checking enabled, it's a function, not + a macro. + * stw.h (struct _ffestw_): New variable for IFTHEN. + (ffestw_ifthen_fake_else, ffestw_set_ifthen_fake_else): New + accessor macros. + * symbol.c, symbol.h: Support new ASSIGN'ed-to info. + + * com.c: Clean up commentary per GNU coding standards. + + * bld.h (ffebld_size, ffebld_size_known): Canonize. + + * version.c: Bump version. + Sun Apr 11 21:33:33 1999 Mumit Khan <khan@xraylith.wisc.edu> * g77spec.c (lang_specific_driver): Check whether MATH_LIBRARY is diff --git a/gcc/f/bld.c b/gcc/f/bld.c index 6ef559e..15cadf1 100644 --- a/gcc/f/bld.c +++ b/gcc/f/bld.c @@ -5573,6 +5573,9 @@ ffebld_new_item (ffebld head, ffebld trail) x->op = FFEBLD_opITEM; x->u.item.head = head; x->u.item.trail = trail; +#ifdef FFECOM_itemHOOK + x->u.item.hook = FFECOM_itemNULL; +#endif return x; } @@ -5655,6 +5658,9 @@ ffebld_new_one (ffebldOp o, ffebld left) #endif x->op = o; x->u.nonter.left = left; +#ifdef FFECOM_nonterHOOK + x->u.nonter.hook = FFECOM_nonterNULL; +#endif return x; } @@ -5703,6 +5709,9 @@ ffebld_new_two (ffebldOp o, ffebld left, ffebld right) x->op = o; x->u.nonter.left = left; x->u.nonter.right = right; +#ifdef FFECOM_nonterHOOK + x->u.nonter.hook = FFECOM_nonterNULL; +#endif return x; } diff --git a/gcc/f/bld.h b/gcc/f/bld.h index 96c8e5e..ddbd448 100644 --- a/gcc/f/bld.h +++ b/gcc/f/bld.h @@ -406,12 +406,18 @@ struct _ffebld_ { ffebld left; ffebld right; +#ifdef FFECOM_nonterHOOK + ffecomNonter hook; /* Whatever the compiler/backend wants! */ +#endif } nonter; struct { ffebld head; ffebld trail; +#ifdef FFECOM_itemHOOK + ffecomItem hook; /* Whatever the compiler/backend wants! */ +#endif } item; struct @@ -748,6 +754,7 @@ ffetargetCharacterSize ffebld_size_max (ffebld b); #define ffebld_arrter_set_pad(b,p) ((b)->u.arrter.pad = (p)) #define ffebld_arrter_set_size(b,s) ((b)->u.arrter.size = (s)) #define ffebld_arrter_size(b) ((b)->u.arrter.size) +#define ffebld_basictype(b) (ffeinfo_basictype (ffebld_info ((b)))) #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ #define ffebld_constant_pool() ffe_pool_program_unit() #elif FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_ @@ -944,6 +951,10 @@ ffetargetCharacterSize ffebld_size_max (ffebld b); #define ffebld_init_3() #define ffebld_init_4() #define ffebld_init_list(l,b) (*(l) = NULL, *(b) = (l)) +#define ffebld_item_hook(b) ((b)->u.item.hook) +#define ffebld_item_set_hook(b,h) ((b)->u.item.hook = (h)) +#define ffebld_kind(b) (ffeinfo_kind (ffebld_info ((b)))) +#define ffebld_kindtype(b) (ffeinfo_kindtype (ffebld_info ((b)))) #define ffebld_labter(b) ((b)->u.labter) #define ffebld_labtok(b) ((b)->u.labtok) #define ffebld_left(b) ((b)->u.nonter.left) @@ -987,8 +998,11 @@ ffetargetCharacterSize ffebld_size_max (ffebld b); #define ffebld_new_arrayref(l,r) ffebld_new_two(FFEBLD_opARRAYREF,(l),(r)) #define ffebld_new_substr(l,r) ffebld_new_two(FFEBLD_opSUBSTR,(l),(r)) #define ffebld_new_impdo(l,r) ffebld_new_two(FFEBLD_opIMPDO,(l),(r)) +#define ffebld_nonter_hook(b) ((b)->u.nonter.hook) +#define ffebld_nonter_set_hook(b,h) ((b)->u.nonter.hook = (h)) #define ffebld_op(b) ((b)->op) #define ffebld_pool() (ffebld_pool_stack_.pool) +#define ffebld_rank(b) (ffeinfo_rank (ffebld_info ((b)))) #define ffebld_right(b) ((b)->u.nonter.right) #define ffebld_set_accter(b,a) ((b)->u.accter.array = (a)) #define ffebld_set_arrter(b,a) ((b)->u.arrter.array = (a)) @@ -1000,8 +1014,8 @@ ffetargetCharacterSize ffebld_size_max (ffebld b); #define ffebld_set_left(b,l) ((b)->u.nonter.left = (l)) #define ffebld_set_right(b,r) ((b)->u.nonter.right = (r)) #define ffebld_set_trail(b,t) ((b)->u.item.trail = (t)) -#define ffebld_size(b) (ffeinfo_size((b)->info)) -#define ffebld_size_known(b) ffebld_size(b) +#define ffebld_size(b) (ffeinfo_size (ffebld_info ((b)))) +#define ffebld_size_known(b) ffebld_size((b)) #define ffebld_symter(b) ((b)->u.symter.symbol) #define ffebld_symter_generic(b) ((b)->u.symter.generic) #define ffebld_symter_doiter(b) ((b)->u.symter.do_iter) @@ -1018,6 +1032,7 @@ ffetargetCharacterSize ffebld_size_max (ffebld b); #define ffebld_terminate_3() #define ffebld_terminate_4() #define ffebld_trail(b) ((b)->u.item.trail) +#define ffebld_where(b) (ffeinfo_where (ffebld_info ((b)))) /* End of #include file. */ diff --git a/gcc/f/com.c b/gcc/f/com.c index dabf049..1d7676d 100644 --- a/gcc/f/com.c +++ b/gcc/f/com.c @@ -60,9 +60,9 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 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); @@ -231,8 +231,8 @@ tree unsigned_type_node; tree char_type_node; tree current_function_decl; -/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference - it. */ +/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c + reference it. */ char *language_string = "GNU F77"; @@ -369,7 +369,6 @@ typedef enum #if FFECOM_targetCURRENT == FFECOM_targetGCC typedef struct _ffecom_concat_list_ ffecomConcatList_; -typedef struct _ffecom_temp_ *ffecomTemp_; #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ /* Private include files. */ @@ -386,18 +385,6 @@ struct _ffecom_concat_list_ 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). */ @@ -416,13 +403,13 @@ static tree ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, tree type, tree args, tree dest_tree, ffebld dest, bool *dest_used, - tree callee_commons, bool scalar_args); + tree 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); @@ -442,7 +429,7 @@ static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used, bool assignp, bool widenp); static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, ffebld dest, bool *dest_used); -static tree ffecom_expr_power_integer_ (ffebld 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, @@ -470,6 +457,8 @@ static void ffecom_member_phase1_ (ffestorag mst, ffestorag st); #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); #endif +static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, + ffebld source); static void ffecom_push_dummy_decls_ (ffebld dumlist, bool stmtfunc); static void ffecom_start_progunit_ (void); @@ -484,7 +473,7 @@ static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset, tree *size, tree tree); static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree, ffebld dest, - bool *dest_used); + bool *dest_used, tree hook); static tree ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt); @@ -504,11 +493,12 @@ static tree ffecom_convert_widen_ (tree type, tree expr); 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); @@ -519,6 +509,7 @@ static void pop_f_function_context (void); static void push_f_function_context (void); static void push_parm_decl (tree parm); static tree pushdecl_top_level (tree decl); +static int kept_level_p (void); static tree storedecls (tree decls); static void store_parm_decls (int is_main_program); static tree start_decl (tree decl, bool is_top_level); @@ -543,8 +534,6 @@ static bool ffecom_primary_entry_is_proc_; 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; @@ -647,9 +636,6 @@ static const char *ffecom_gfrt_argstring_[FFECOM_gfrt] #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) @@ -669,20 +655,27 @@ static const char *ffecom_gfrt_argstring_[FFECOM_gfrt] 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 @@ -705,7 +698,7 @@ static struct binding_level *global_binding_level; 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. */ @@ -752,7 +745,6 @@ static tree shadowed_labels; #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ - /* This is like gcc's stabilize_reference -- in fact, most of the code comes from that -- but it handles the situation where the reference is going to have its subparts picked at, and it shouldn't change @@ -1563,7 +1555,7 @@ static tree ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, tree type, tree args, tree dest_tree, ffebld dest, bool *dest_used, tree callee_commons, - bool scalar_args) + bool scalar_args, tree hook) { tree item; tree tempvar; @@ -1583,10 +1575,15 @@ ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 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 { @@ -1598,7 +1595,7 @@ ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 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; @@ -1627,17 +1624,15 @@ static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, tree type, ffebld left, ffebld right, tree dest_tree, ffebld dest, bool *dest_used, - tree callee_commons, bool scalar_args) + tree 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); @@ -1660,17 +1655,11 @@ ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 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- @@ -1696,15 +1685,17 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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 @@ -1742,7 +1733,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) } 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)) @@ -1758,9 +1750,7 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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) { @@ -1805,9 +1795,7 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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) { @@ -1892,7 +1880,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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; @@ -1901,7 +1890,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) == 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; @@ -1929,14 +1919,16 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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. */ @@ -1962,16 +1954,12 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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) { @@ -1988,9 +1976,13 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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); @@ -2004,7 +1996,7 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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); @@ -2082,10 +2074,10 @@ ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s) { 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; @@ -2182,7 +2174,8 @@ recurse: /* :::::::::::::::::::: */ 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); @@ -2243,12 +2236,7 @@ ffecom_concat_list_kill_ (ffecomConcatList_ catlist) } #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. */ @@ -2526,7 +2514,7 @@ ffecom_do_entry_ (ffesymbol fn, int entrynum) 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. */ @@ -2556,7 +2544,9 @@ ffecom_do_entry_ (ffesymbol fn, int entrynum) 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. */ @@ -2565,7 +2555,7 @@ ffecom_do_entry_ (ffesymbol fn, int entrynum) 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); @@ -2726,7 +2716,7 @@ ffecom_do_entry_ (ffesymbol fn, int entrynum) clear_momentary (); } - ffecom_end_compstmt_ (); + ffecom_end_compstmt (); finish_function (0); @@ -3040,7 +3030,8 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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); @@ -3096,7 +3087,8 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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: { @@ -3111,7 +3103,7 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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; } @@ -3228,7 +3220,8 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, && 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: @@ -3277,12 +3270,10 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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; @@ -3295,7 +3286,8 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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; @@ -3513,8 +3505,6 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, } case FFEINFO_basictypeCHARACTER: - ffecom_push_calltemps (); /* Even though we might not call. */ - { ffebld left = ffebld_left (expr); ffebld right = ffebld_right (expr); @@ -3546,10 +3536,7 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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)) @@ -3582,7 +3569,7 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, 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), @@ -3591,7 +3578,6 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest, item = convert (tree_type, item); } - ffecom_pop_calltemps (); return item; default: @@ -3793,8 +3779,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); */ @@ -3810,14 +3796,16 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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 @@ -3862,7 +3850,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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, @@ -3871,7 +3860,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, arg1_type, convert (arg1_type, ffecom_float_half_), - saved_expr1))))) + saved_expr1))), + NULL_TREE)) ) ); #endif @@ -3886,9 +3876,12 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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))); @@ -4138,8 +4131,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); */ @@ -4552,13 +4545,11 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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, @@ -4567,8 +4558,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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, @@ -4686,8 +4675,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -4703,12 +4690,10 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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; @@ -4721,7 +4706,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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 @@ -4737,8 +4723,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -4754,12 +4738,10 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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; @@ -4770,7 +4752,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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 @@ -4793,17 +4776,13 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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; @@ -4814,7 +4793,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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 (arg2_tree != NULL_TREE) expr_tree @@ -4840,7 +4820,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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) @@ -4860,17 +4841,13 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); @@ -4883,7 +4860,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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), @@ -4899,19 +4877,15 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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); @@ -4922,7 +4896,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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), @@ -4938,8 +4913,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -4947,9 +4920,7 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); @@ -4962,7 +4933,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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)); @@ -4975,8 +4947,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -4989,9 +4959,7 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); @@ -5001,7 +4969,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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), @@ -5016,8 +4985,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -5033,9 +5000,7 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); @@ -5045,7 +5010,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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), @@ -5061,8 +5027,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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) ? @@ -5073,8 +5037,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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); @@ -5087,7 +5049,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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; @@ -5116,7 +5079,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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; @@ -5126,8 +5090,6 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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, @@ -5137,9 +5099,7 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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), @@ -5147,7 +5107,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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), @@ -5161,11 +5122,7 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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), @@ -5173,7 +5130,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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, @@ -5188,28 +5146,25 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_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: @@ -5290,890 +5245,20 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */ - ffecom_push_calltemps (); expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), ffebld_right (expr)); - ffecom_pop_calltemps (); return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt), (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]), tree_type, expr_tree, dest_tree, dest, dest_used, - NULL_TREE, TRUE); - - /**INDENT* (Do not reformat this comment even with -fca option.) - Data-gathering files: Given the source file listed below, compiled with - f2c I obtained the output file listed after that, and from the output - file I derived the above code. + NULL_TREE, TRUE, + ffebld_nonter_hook (expr)); --------- (begin input file to f2c) - implicit none - character*10 A1,A2 - complex C1,C2 - integer I1,I2 - real R1,R2 - double precision D1,D2 -C - call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) -c / - call fooI(I1/I2) - call fooR(R1/I1) - call fooD(D1/I1) - call fooC(C1/I1) - call fooR(R1/R2) - call fooD(R1/D1) - call fooD(D1/D2) - call fooD(D1/R1) - call fooC(C1/C2) - call fooC(C1/R1) - call fooZ(C1/D1) -c ** - call fooI(I1**I2) - call fooR(R1**I1) - call fooD(D1**I1) - call fooC(C1**I1) - call fooR(R1**R2) - call fooD(R1**D1) - call fooD(D1**D2) - call fooD(D1**R1) - call fooC(C1**C2) - call fooC(C1**R1) - call fooZ(C1**D1) -c FFEINTRIN_impABS - call fooR(ABS(R1)) -c FFEINTRIN_impACOS - call fooR(ACOS(R1)) -c FFEINTRIN_impAIMAG - call fooR(AIMAG(C1)) -c FFEINTRIN_impAINT - call fooR(AINT(R1)) -c FFEINTRIN_impALOG - call fooR(ALOG(R1)) -c FFEINTRIN_impALOG10 - call fooR(ALOG10(R1)) -c FFEINTRIN_impAMAX0 - call fooR(AMAX0(I1,I2)) -c FFEINTRIN_impAMAX1 - call fooR(AMAX1(R1,R2)) -c FFEINTRIN_impAMIN0 - call fooR(AMIN0(I1,I2)) -c FFEINTRIN_impAMIN1 - call fooR(AMIN1(R1,R2)) -c FFEINTRIN_impAMOD - call fooR(AMOD(R1,R2)) -c FFEINTRIN_impANINT - call fooR(ANINT(R1)) -c FFEINTRIN_impASIN - call fooR(ASIN(R1)) -c FFEINTRIN_impATAN - call fooR(ATAN(R1)) -c FFEINTRIN_impATAN2 - call fooR(ATAN2(R1,R2)) -c FFEINTRIN_impCABS - call fooR(CABS(C1)) -c FFEINTRIN_impCCOS - call fooC(CCOS(C1)) -c FFEINTRIN_impCEXP - call fooC(CEXP(C1)) -c FFEINTRIN_impCHAR - call fooA(CHAR(I1)) -c FFEINTRIN_impCLOG - call fooC(CLOG(C1)) -c FFEINTRIN_impCONJG - call fooC(CONJG(C1)) -c FFEINTRIN_impCOS - call fooR(COS(R1)) -c FFEINTRIN_impCOSH - call fooR(COSH(R1)) -c FFEINTRIN_impCSIN - call fooC(CSIN(C1)) -c FFEINTRIN_impCSQRT - call fooC(CSQRT(C1)) -c FFEINTRIN_impDABS - call fooD(DABS(D1)) -c FFEINTRIN_impDACOS - call fooD(DACOS(D1)) -c FFEINTRIN_impDASIN - call fooD(DASIN(D1)) -c FFEINTRIN_impDATAN - call fooD(DATAN(D1)) -c FFEINTRIN_impDATAN2 - call fooD(DATAN2(D1,D2)) -c FFEINTRIN_impDCOS - call fooD(DCOS(D1)) -c FFEINTRIN_impDCOSH - call fooD(DCOSH(D1)) -c FFEINTRIN_impDDIM - call fooD(DDIM(D1,D2)) -c FFEINTRIN_impDEXP - call fooD(DEXP(D1)) -c FFEINTRIN_impDIM - call fooR(DIM(R1,R2)) -c FFEINTRIN_impDINT - call fooD(DINT(D1)) -c FFEINTRIN_impDLOG - call fooD(DLOG(D1)) -c FFEINTRIN_impDLOG10 - call fooD(DLOG10(D1)) -c FFEINTRIN_impDMAX1 - call fooD(DMAX1(D1,D2)) -c FFEINTRIN_impDMIN1 - call fooD(DMIN1(D1,D2)) -c FFEINTRIN_impDMOD - call fooD(DMOD(D1,D2)) -c FFEINTRIN_impDNINT - call fooD(DNINT(D1)) -c FFEINTRIN_impDPROD - call fooD(DPROD(R1,R2)) -c FFEINTRIN_impDSIGN - call fooD(DSIGN(D1,D2)) -c FFEINTRIN_impDSIN - call fooD(DSIN(D1)) -c FFEINTRIN_impDSINH - call fooD(DSINH(D1)) -c FFEINTRIN_impDSQRT - call fooD(DSQRT(D1)) -c FFEINTRIN_impDTAN - call fooD(DTAN(D1)) -c FFEINTRIN_impDTANH - call fooD(DTANH(D1)) -c FFEINTRIN_impEXP - call fooR(EXP(R1)) -c FFEINTRIN_impIABS - call fooI(IABS(I1)) -c FFEINTRIN_impICHAR - call fooI(ICHAR(A1)) -c FFEINTRIN_impIDIM - call fooI(IDIM(I1,I2)) -c FFEINTRIN_impIDNINT - call fooI(IDNINT(D1)) -c FFEINTRIN_impINDEX - call fooI(INDEX(A1,A2)) -c FFEINTRIN_impISIGN - call fooI(ISIGN(I1,I2)) -c FFEINTRIN_impLEN - call fooI(LEN(A1)) -c FFEINTRIN_impLGE - call fooL(LGE(A1,A2)) -c FFEINTRIN_impLGT - call fooL(LGT(A1,A2)) -c FFEINTRIN_impLLE - call fooL(LLE(A1,A2)) -c FFEINTRIN_impLLT - call fooL(LLT(A1,A2)) -c FFEINTRIN_impMAX0 - call fooI(MAX0(I1,I2)) -c FFEINTRIN_impMAX1 - call fooI(MAX1(R1,R2)) -c FFEINTRIN_impMIN0 - call fooI(MIN0(I1,I2)) -c FFEINTRIN_impMIN1 - call fooI(MIN1(R1,R2)) -c FFEINTRIN_impMOD - call fooI(MOD(I1,I2)) -c FFEINTRIN_impNINT - call fooI(NINT(R1)) -c FFEINTRIN_impSIGN - call fooR(SIGN(R1,R2)) -c FFEINTRIN_impSIN - call fooR(SIN(R1)) -c FFEINTRIN_impSINH - call fooR(SINH(R1)) -c FFEINTRIN_impSQRT - call fooR(SQRT(R1)) -c FFEINTRIN_impTAN - call fooR(TAN(R1)) -c FFEINTRIN_impTANH - call fooR(TANH(R1)) -c FFEINTRIN_imp_CMPLX_C - call fooC(cmplx(C1,C2)) -c FFEINTRIN_imp_CMPLX_D - call fooZ(cmplx(D1,D2)) -c FFEINTRIN_imp_CMPLX_I - call fooC(cmplx(I1,I2)) -c FFEINTRIN_imp_CMPLX_R - call fooC(cmplx(R1,R2)) -c FFEINTRIN_imp_DBLE_C - call fooD(dble(C1)) -c FFEINTRIN_imp_DBLE_D - call fooD(dble(D1)) -c FFEINTRIN_imp_DBLE_I - call fooD(dble(I1)) -c FFEINTRIN_imp_DBLE_R - call fooD(dble(R1)) -c FFEINTRIN_imp_INT_C - call fooI(int(C1)) -c FFEINTRIN_imp_INT_D - call fooI(int(D1)) -c FFEINTRIN_imp_INT_I - call fooI(int(I1)) -c FFEINTRIN_imp_INT_R - call fooI(int(R1)) -c FFEINTRIN_imp_REAL_C - call fooR(real(C1)) -c FFEINTRIN_imp_REAL_D - call fooR(real(D1)) -c FFEINTRIN_imp_REAL_I - call fooR(real(I1)) -c FFEINTRIN_imp_REAL_R - call fooR(real(R1)) -c -c FFEINTRIN_imp_INT_D: -c -c FFEINTRIN_specIDINT - call fooI(IDINT(D1)) -c -c FFEINTRIN_imp_INT_R: -c -c FFEINTRIN_specIFIX - call fooI(IFIX(R1)) -c FFEINTRIN_specINT - call fooI(INT(R1)) -c -c FFEINTRIN_imp_REAL_D: -c -c FFEINTRIN_specSNGL - call fooR(SNGL(D1)) -c -c FFEINTRIN_imp_REAL_I: -c -c FFEINTRIN_specFLOAT - call fooR(FLOAT(I1)) -c FFEINTRIN_specREAL - call fooR(REAL(I1)) -c - end --------- (end input file to f2c) - --------- (begin output from providing above input file as input to: --------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ --------- -e "s:^#.*$::g"') - -// -- translated by f2c (version 19950223). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -// - - -// f2c.h -- Standard Fortran to C header file // - -/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // - - - - -// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // -// we assume short, float are OK // -typedef long int // long int // integer; -typedef char *address; -typedef short int shortint; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -typedef long int // long int // logical; -typedef short int shortlogical; -typedef char logical1; -typedef char integer1; -// typedef long long longint; // // system-dependent // - - - - -// Extern is for use with -E // - - - - -// I/O stuff // - - - - - - - - -typedef long int // int or long int // flag; -typedef long int // int or long int // ftnlen; -typedef long int // int or long int // ftnint; - - -//external read, write// -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -//internal read, write// -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -//open// -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -//close// -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -//rewind, backspace, endfile// -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -// inquire // -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; //parameters in standard's order// - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - - - -union Multitype { // for multiple entry points // - integer1 g; - shortint h; - integer i; - // longint j; // - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -typedef long Long; // No longer used; formerly in Namelist // - -struct Vardesc { // for Namelist // - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - - - - - - - - -// procedure parameter types for -A and -C++ // - - - - -typedef int // Unknown procedure type // (*U_fp)(); -typedef shortint (*J_fp)(); -typedef integer (*I_fp)(); -typedef real (*R_fp)(); -typedef doublereal (*D_fp)(), (*E_fp)(); -typedef // Complex // void (*C_fp)(); -typedef // Double Complex // void (*Z_fp)(); -typedef logical (*L_fp)(); -typedef shortlogical (*K_fp)(); -typedef // Character // void (*H_fp)(); -typedef // Subroutine // int (*S_fp)(); - -// E_fp is for real functions when -R is not specified // -typedef void C_f; // complex function // -typedef void H_f; // character function // -typedef void Z_f; // double complex function // -typedef doublereal E_f; // real function with -R not specified // - -// undef any lower-case symbols that your C compiler predefines, e.g.: // - - -// (No such symbols should be defined in a strict ANSI C compiler. - We can avoid trouble with f2c-translated code by using - gcc -ansi [-traditional].) // - - - - - - - - - - - - - - - - - - - - - - - -// Main program // MAIN__() -{ - // System generated locals // - integer i__1; - real r__1, r__2; - doublereal d__1, d__2; - complex q__1; - doublecomplex z__1, z__2, z__3; - logical L__1; - char ch__1[1]; - - // Builtin functions // - void c_div(); - integer pow_ii(); - double pow_ri(), pow_di(); - void pow_ci(); - double pow_dd(); - void pow_zz(); - double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), - asin(), atan(), atan2(), c_abs(); - void c_cos(), c_exp(), c_log(), r_cnjg(); - double cos(), cosh(); - void c_sin(), c_sqrt(); - double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), - d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); - integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); - logical l_ge(), l_gt(), l_le(), l_lt(); - integer i_nint(); - double r_sign(); - - // Local variables // - extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), - fool_(), fooz_(), getem_(); - static char a1[10], a2[10]; - static complex c1, c2; - static doublereal d1, d2; - static integer i1, i2; - static real r1, r2; - - - getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); -// / // - i__1 = i1 / i2; - fooi_(&i__1); - r__1 = r1 / i1; - foor_(&r__1); - d__1 = d1 / i1; - food_(&d__1); - d__1 = (doublereal) i1; - q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; - fooc_(&q__1); - r__1 = r1 / r2; - foor_(&r__1); - d__1 = r1 / d1; - food_(&d__1); - d__1 = d1 / d2; - food_(&d__1); - d__1 = d1 / r1; - food_(&d__1); - c_div(&q__1, &c1, &c2); - fooc_(&q__1); - q__1.r = c1.r / r1, q__1.i = c1.i / r1; - fooc_(&q__1); - z__1.r = c1.r / d1, z__1.i = c1.i / d1; - fooz_(&z__1); -// ** // - i__1 = pow_ii(&i1, &i2); - fooi_(&i__1); - r__1 = pow_ri(&r1, &i1); - foor_(&r__1); - d__1 = pow_di(&d1, &i1); - food_(&d__1); - pow_ci(&q__1, &c1, &i1); - fooc_(&q__1); - d__1 = (doublereal) r1; - d__2 = (doublereal) r2; - r__1 = pow_dd(&d__1, &d__2); - foor_(&r__1); - d__2 = (doublereal) r1; - d__1 = pow_dd(&d__2, &d1); - food_(&d__1); - d__1 = pow_dd(&d1, &d2); - food_(&d__1); - d__2 = (doublereal) r1; - d__1 = pow_dd(&d1, &d__2); - food_(&d__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = c2.r, z__3.i = c2.i; - pow_zz(&z__1, &z__2, &z__3); - q__1.r = z__1.r, q__1.i = z__1.i; - fooc_(&q__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = r1, z__3.i = 0.; - pow_zz(&z__1, &z__2, &z__3); - q__1.r = z__1.r, q__1.i = z__1.i; - fooc_(&q__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = d1, z__3.i = 0.; - pow_zz(&z__1, &z__2, &z__3); - fooz_(&z__1); -// FFEINTRIN_impABS // - r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; - foor_(&r__1); -// FFEINTRIN_impACOS // - r__1 = acos(r1); - foor_(&r__1); -// FFEINTRIN_impAIMAG // - r__1 = r_imag(&c1); - foor_(&r__1); -// FFEINTRIN_impAINT // - r__1 = r_int(&r1); - foor_(&r__1); -// FFEINTRIN_impALOG // - r__1 = log(r1); - foor_(&r__1); -// FFEINTRIN_impALOG10 // - r__1 = r_lg10(&r1); - foor_(&r__1); -// FFEINTRIN_impAMAX0 // - r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMAX1 // - r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMIN0 // - r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMIN1 // - r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMOD // - r__1 = r_mod(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impANINT // - r__1 = r_nint(&r1); - foor_(&r__1); -// FFEINTRIN_impASIN // - r__1 = asin(r1); - foor_(&r__1); -// FFEINTRIN_impATAN // - r__1 = atan(r1); - foor_(&r__1); -// FFEINTRIN_impATAN2 // - r__1 = atan2(r1, r2); - foor_(&r__1); -// FFEINTRIN_impCABS // - r__1 = c_abs(&c1); - foor_(&r__1); -// FFEINTRIN_impCCOS // - c_cos(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCEXP // - c_exp(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCHAR // - *(unsigned char *)&ch__1[0] = i1; - fooa_(ch__1, 1L); -// FFEINTRIN_impCLOG // - c_log(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCONJG // - r_cnjg(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCOS // - r__1 = cos(r1); - foor_(&r__1); -// FFEINTRIN_impCOSH // - r__1 = cosh(r1); - foor_(&r__1); -// FFEINTRIN_impCSIN // - c_sin(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCSQRT // - c_sqrt(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impDABS // - d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; - food_(&d__1); -// FFEINTRIN_impDACOS // - d__1 = acos(d1); - food_(&d__1); -// FFEINTRIN_impDASIN // - d__1 = asin(d1); - food_(&d__1); -// FFEINTRIN_impDATAN // - d__1 = atan(d1); - food_(&d__1); -// FFEINTRIN_impDATAN2 // - d__1 = atan2(d1, d2); - food_(&d__1); -// FFEINTRIN_impDCOS // - d__1 = cos(d1); - food_(&d__1); -// FFEINTRIN_impDCOSH // - d__1 = cosh(d1); - food_(&d__1); -// FFEINTRIN_impDDIM // - d__1 = d_dim(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDEXP // - d__1 = exp(d1); - food_(&d__1); -// FFEINTRIN_impDIM // - r__1 = r_dim(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impDINT // - d__1 = d_int(&d1); - food_(&d__1); -// FFEINTRIN_impDLOG // - d__1 = log(d1); - food_(&d__1); -// FFEINTRIN_impDLOG10 // - d__1 = d_lg10(&d1); - food_(&d__1); -// FFEINTRIN_impDMAX1 // - d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; - food_(&d__1); -// FFEINTRIN_impDMIN1 // - d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; - food_(&d__1); -// FFEINTRIN_impDMOD // - d__1 = d_mod(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDNINT // - d__1 = d_nint(&d1); - food_(&d__1); -// FFEINTRIN_impDPROD // - d__1 = (doublereal) r1 * r2; - food_(&d__1); -// FFEINTRIN_impDSIGN // - d__1 = d_sign(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDSIN // - d__1 = sin(d1); - food_(&d__1); -// FFEINTRIN_impDSINH // - d__1 = sinh(d1); - food_(&d__1); -// FFEINTRIN_impDSQRT // - d__1 = sqrt(d1); - food_(&d__1); -// FFEINTRIN_impDTAN // - d__1 = tan(d1); - food_(&d__1); -// FFEINTRIN_impDTANH // - d__1 = tanh(d1); - food_(&d__1); -// FFEINTRIN_impEXP // - r__1 = exp(r1); - foor_(&r__1); -// FFEINTRIN_impIABS // - i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; - fooi_(&i__1); -// FFEINTRIN_impICHAR // - i__1 = *(unsigned char *)a1; - fooi_(&i__1); -// FFEINTRIN_impIDIM // - i__1 = i_dim(&i1, &i2); - fooi_(&i__1); -// FFEINTRIN_impIDNINT // - i__1 = i_dnnt(&d1); - fooi_(&i__1); -// FFEINTRIN_impINDEX // - i__1 = i_indx(a1, a2, 10L, 10L); - fooi_(&i__1); -// FFEINTRIN_impISIGN // - i__1 = i_sign(&i1, &i2); - fooi_(&i__1); -// FFEINTRIN_impLEN // - i__1 = i_len(a1, 10L); - fooi_(&i__1); -// FFEINTRIN_impLGE // - L__1 = l_ge(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLGT // - L__1 = l_gt(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLLE // - L__1 = l_le(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLLT // - L__1 = l_lt(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impMAX0 // - i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMAX1 // - i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMIN0 // - i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMIN1 // - i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMOD // - i__1 = i1 % i2; - fooi_(&i__1); -// FFEINTRIN_impNINT // - i__1 = i_nint(&r1); - fooi_(&i__1); -// FFEINTRIN_impSIGN // - r__1 = r_sign(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impSIN // - r__1 = sin(r1); - foor_(&r__1); -// FFEINTRIN_impSINH // - r__1 = sinh(r1); - foor_(&r__1); -// FFEINTRIN_impSQRT // - r__1 = sqrt(r1); - foor_(&r__1); -// FFEINTRIN_impTAN // - r__1 = tan(r1); - foor_(&r__1); -// FFEINTRIN_impTANH // - r__1 = tanh(r1); - foor_(&r__1); -// FFEINTRIN_imp_CMPLX_C // - r__1 = c1.r; - r__2 = c2.r; - q__1.r = r__1, q__1.i = r__2; - fooc_(&q__1); -// FFEINTRIN_imp_CMPLX_D // - z__1.r = d1, z__1.i = d2; - fooz_(&z__1); -// FFEINTRIN_imp_CMPLX_I // - r__1 = (real) i1; - r__2 = (real) i2; - q__1.r = r__1, q__1.i = r__2; - fooc_(&q__1); -// FFEINTRIN_imp_CMPLX_R // - q__1.r = r1, q__1.i = r2; - fooc_(&q__1); -// FFEINTRIN_imp_DBLE_C // - d__1 = (doublereal) c1.r; - food_(&d__1); -// FFEINTRIN_imp_DBLE_D // - d__1 = d1; - food_(&d__1); -// FFEINTRIN_imp_DBLE_I // - d__1 = (doublereal) i1; - food_(&d__1); -// FFEINTRIN_imp_DBLE_R // - d__1 = (doublereal) r1; - food_(&d__1); -// FFEINTRIN_imp_INT_C // - i__1 = (integer) c1.r; - fooi_(&i__1); -// FFEINTRIN_imp_INT_D // - i__1 = (integer) d1; - fooi_(&i__1); -// FFEINTRIN_imp_INT_I // - i__1 = i1; - fooi_(&i__1); -// FFEINTRIN_imp_INT_R // - i__1 = (integer) r1; - fooi_(&i__1); -// FFEINTRIN_imp_REAL_C // - r__1 = c1.r; - foor_(&r__1); -// FFEINTRIN_imp_REAL_D // - r__1 = (real) d1; - foor_(&r__1); -// FFEINTRIN_imp_REAL_I // - r__1 = (real) i1; - foor_(&r__1); -// FFEINTRIN_imp_REAL_R // - r__1 = r1; - foor_(&r__1); - -// FFEINTRIN_imp_INT_D: // - -// FFEINTRIN_specIDINT // - i__1 = (integer) d1; - fooi_(&i__1); - -// FFEINTRIN_imp_INT_R: // - -// FFEINTRIN_specIFIX // - i__1 = (integer) r1; - fooi_(&i__1); -// FFEINTRIN_specINT // - i__1 = (integer) r1; - fooi_(&i__1); - -// FFEINTRIN_imp_REAL_D: // - -// FFEINTRIN_specSNGL // - r__1 = (real) d1; - foor_(&r__1); - -// FFEINTRIN_imp_REAL_I: // - -// FFEINTRIN_specFLOAT // - r__1 = (real) i1; - foor_(&r__1); -// FFEINTRIN_specREAL // - r__1 = (real) i1; - foor_(&r__1); - -} // MAIN__ // - --------- (end output file from f2c) - -*/ + /* 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. */ } #endif @@ -6183,10 +5268,10 @@ typedef doublereal E_f; // real function with -R not specified // #if FFECOM_targetCURRENT == FFECOM_targetGCC static tree -ffecom_expr_power_integer_ (ffebld left, ffebld right) +ffecom_expr_power_integer_ (ffebld expr) { - tree l = ffecom_expr (left); - tree r = ffecom_expr (right); + 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; @@ -6212,7 +5297,7 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) result = ffecom_tree_divide_ (ltype, convert (ltype, integer_one_node), l, - NULL_TREE, NULL, NULL); + NULL_TREE, NULL, NULL, NULL_TREE); r = ffecom_1 (NEGATE_EXPR, rtype, r); @@ -6231,7 +5316,8 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) l = ffecom_tree_divide_ (ltype, convert (ltype, integer_one_node), l, - NULL_TREE, NULL, NULL); + NULL_TREE, NULL, NULL, + ffebld_nonter_hook (expr)); r = ffecom_1 (NEGATE_EXPR, rtype, r); assert (TREE_CODE (r) == INTEGER_CST); @@ -6351,21 +5437,50 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) { tree rtmp; tree ltmp; + tree divide; tree basetypeof_l_is_int; tree se; + tree t; basetypeof_l_is_int = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); se = expand_start_stmt_expr (); - ffecom_push_calltemps (); - rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1, - TRUE); - ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, - TRUE); - result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, - TRUE); + 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 */ expand_expr_stmt (ffecom_modify (void_type_node, rtmp, @@ -6382,7 +5497,7 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) result, convert (ltype, integer_one_node))); expand_start_else (); - if (!integer_zerop (basetypeof_l_is_int)) + if (! integer_zerop (basetypeof_l_is_int)) { expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, rtmp, @@ -6395,7 +5510,8 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) (ltype, convert (ltype, integer_one_node), ltmp, - NULL_TREE, NULL, NULL))); + 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, @@ -6439,7 +5555,8 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) (ltype, convert (ltype, integer_one_node), ltmp, - NULL_TREE, NULL, NULL))); + NULL_TREE, NULL, NULL, + divide))); expand_expr_stmt (ffecom_modify (void_type_node, rtmp, ffecom_1 (NEGATE_EXPR, rtype, @@ -6494,9 +5611,24 @@ ffecom_expr_power_integer_ (ffebld left, ffebld right) expand_end_cond (); expand_expr_stmt (result); - ffecom_pop_calltemps (); + t = ffecom_end_compstmt (); + result = expand_end_stmt_expr (se); - TREE_SIDE_EFFECTS (result) = 1; + + /* 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; @@ -6634,7 +5766,7 @@ ffecom_f2c_make_type_ (tree *type, int tcode, const char *name) pushdecl (build_decl (TYPE_DECL, ffecom_get_invented_identifier ("__g77_f2c_%s", - name, 0), + name, -1), *type)); } @@ -6904,8 +6036,6 @@ ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) push_f_function_context (); - ffecom_push_calltemps (); - if (charfunc) type = void_type_node; else @@ -6934,7 +6064,7 @@ ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; result = ffecom_get_invented_identifier ("__g77_%s", - "result", 0); + "result", -1); ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ @@ -6952,7 +6082,7 @@ ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) store_parm_decls (0); - ffecom_start_compstmt_ (); + ffecom_start_compstmt (); if (expr != NULL) { @@ -6964,24 +6094,32 @@ ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) result_length = build_int_2 (sz, 0); TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; + ffecom_prepare_let_char_ (sz, expr); + + ffecom_prepare_end (); + ffecom_let_char_ (result, result_length, sz, expr); expand_null_return (); } else - expand_return (ffecom_modify (NULL_TREE, - DECL_RESULT (current_function_decl), - ffecom_expr (expr))); + { + ffecom_prepare_expr (expr); + + ffecom_prepare_end (); + + expand_return (ffecom_modify (NULL_TREE, + DECL_RESULT (current_function_decl), + ffecom_expr (expr))); + } clear_momentary (); } - ffecom_end_compstmt_ (); + ffecom_end_compstmt (); func = current_function_decl; finish_function (1); - ffecom_pop_calltemps (); - pop_f_function_context (); resume_momentary (yes); @@ -7105,9 +6243,7 @@ ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, case FFEBLD_opARRAYREF: case FFEBLD_opFUNCREF: case FFEBLD_opSUBSTR: - ffecom_push_calltemps (); ffecom_char_args_ (&expr_tree, &length_tree, arg); - ffecom_pop_calltemps (); if ((expr_tree == error_mark_node) || (length_tree == error_mark_node)) @@ -7333,13 +6469,7 @@ ffecom_intrinsic_len_ (ffebld expr) } #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); +/* Handle CHARACTER assignments. Generates code to do the assignment. Used by ordinary assignment statement handler ffecom_let_stmt and by statement-function @@ -7386,7 +6516,7 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) = build_tree_list (NULL_TREE, source_length); - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); TREE_SIDE_EFFECTS (expr_tree) = 1; expand_expr_stmt (expr_tree); @@ -7443,7 +6573,7 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) = build_tree_list (NULL_TREE, source_length); - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); TREE_SIDE_EFFECTS (expr_tree) = 1; expand_expr_stmt (expr_tree); @@ -7466,6 +6596,7 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, tree citem; tree clength; +#ifdef HOHO length_array = lengths = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, @@ -7473,6 +6604,18 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, 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); + } +#endif for (i = 0; i < count; ++i) { @@ -7525,7 +6668,7 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) = build_tree_list (NULL_TREE, dest_length); - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree); + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE); TREE_SIDE_EFFECTS (expr_tree) = 1; expand_expr_stmt (expr_tree); @@ -7704,6 +6847,51 @@ ffecom_member_phase2_ (ffestorag mst, ffestorag st) #endif #endif +/* Prepare source expression for assignment into a destination perhaps known + to be of a specific size. */ + +static void +ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source) +{ + ffecomConcatList_ catlist; + int count; + int i; + tree ltmp; + tree itmp; + tree tempvar = NULL_TREE; + + while (ffebld_op (source) == FFEBLD_opCONVERT) + source = ffebld_left (source); + + catlist = ffecom_concat_list_new_ (source, dest_size); + count = ffecom_concat_list_count_ (catlist); + + if (count >= 2) + { + ltmp + = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count); + itmp + = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count); + + tempvar = make_tree_vec (2); + TREE_VEC_ELT (tempvar, 0) = ltmp; + TREE_VEC_ELT (tempvar, 1) = itmp; + } + + for (i = 0; i < count; ++i) + ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i)); + + ffecom_concat_list_kill_ (catlist); + + if (tempvar) + { + ffebld_nonter_set_hook (source, tempvar); + current_binding_level->prep_state = 1; + } +} + /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order Ignores STAR (alternate-return) dummies. All other get exec-transitioned @@ -7920,7 +7108,7 @@ ffecom_start_progunit_ () { id = ffecom_get_invented_identifier ("__g77_masterfun_%s", ffesymbol_text (fn), - 0); + -1); } #if FFETARGET_isENFORCED_MAIN else if (main_program) @@ -7956,7 +7144,7 @@ ffecom_start_progunit_ () = build_decl (PARM_DECL, ffecom_get_invented_identifier ("__g77_%s", "which_entrypoint", - 0), + -1), integer_type_node); push_parm_decl (ffecom_which_entrypoint_decl_); } @@ -7976,7 +7164,7 @@ ffecom_start_progunit_ () type = ffecom_multi_type_node_; result = ffecom_get_invented_identifier ("__g77_%s", - "result", 0); + "result", -1); /* Make length arg _and_ enhance type info for CHAR arg itself. */ @@ -8015,7 +7203,9 @@ ffecom_start_progunit_ () if (TREE_CODE (current_function_decl) != ERROR_MARK) store_parm_decls (main_program ? 1 : 0); - ffecom_start_compstmt_ (); + ffecom_start_compstmt (); + /* Disallow temp vars at this level. */ + current_binding_level->prep_state = 2; lineno = old_lineno; input_filename = old_input_filename; @@ -8052,6 +7242,20 @@ ffecom_sym_transform_ (ffesymbol s) int old_lineno = lineno; char *old_input_filename = input_filename; + /* Must ensure special ASSIGN variables are declared at top of outermost + block, else they'll end up in the innermost block when their first + ASSIGN is seen, which leaves them out of scope when they're the + subject of a GOTO or I/O statement. + + We make this variable even if -fugly-assign. Just let it go unused, + in case it turns out there are cases where we really want to use this + variable anyway (e.g. ASSIGN to INTEGER*2 variable). */ + + if (! ffecom_transform_only_dummies_ + && ffesymbol_assigned (s) + && ! ffesymbol_hook (s).assign_tree) + s = ffecom_sym_transform_assign_ (s); + if (ffesymbol_sfdummyparent (s) == NULL) { input_filename = ffesymbol_where_filename (s); @@ -8144,7 +7348,8 @@ ffecom_sym_transform_ (ffesymbol s) switch (ffeinfo_where (ffesymbol_info (s))) { - case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */ + case FFEINFO_whereCONSTANT: + /* ~~Debugging info needed? */ assert (!ffecom_transform_only_dummies_); t = error_mark_node; /* Shouldn't ever see this in expr. */ break; @@ -8547,13 +7752,13 @@ ffecom_sym_transform_ (ffesymbol s) ffecom_integer_zero_node); #endif - /* ~~~gcc/stor-layout.c/layout_type should do this, + /* ~~~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 + /* ~~~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) @@ -9122,7 +8327,7 @@ ffecom_sym_transform_assign_ (ffesymbol s) t = build_decl (VAR_DECL, ffecom_get_invented_identifier ("__g77_ASSIGN_%s", ffesymbol_text (s), - 0), + -1), TREE_TYPE (null_pointer_node)); switch (ffesymbol_where (s)) @@ -9442,7 +8647,7 @@ ffecom_transform_equiv_ (ffestorag eqst) ffesymbol_text (ffestorag_symbol (eqst)), - 0), + -1), eqtype); DECL_EXTERNAL (eqt) = 0; if (is_init @@ -9847,7 +9052,8 @@ ffecom_tree_canonize_ref_ (tree *decl, tree *offset, #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 dest_tree, ffebld dest, bool *dest_used, + tree hook) { if ((left == error_mark_node) || (right == error_mark_node)) @@ -9886,7 +9092,7 @@ ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree_type, left, dest_tree, dest, dest_used, - NULL_TREE, TRUE); + NULL_TREE, TRUE, hook); } break; @@ -9916,7 +9122,7 @@ ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree_type, left, dest_tree, dest, dest_used, - NULL_TREE, TRUE); + NULL_TREE, TRUE, hook); } break; @@ -9928,16 +9134,7 @@ ffecom_tree_divide_ (tree tree_type, tree left, tree right, } #endif -/* ffecom_type_localvar_ -- Build type info for non-dummy variable - - tree type; - ffesymbol s; // the variable's symbol - ffeinfoBasictype bt; // it's basictype - ffeinfoKindtype kt; // it's kindtype - - type = ffecom_type_localvar_(s,bt,kt); - - Handles static arrays, CHARACTER type, etc. */ +/* Build type info for non-dummy variable. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static tree @@ -10900,6 +10097,7 @@ ffecom_3s (enum tree_code code, tree type, tree node1, } #endif + /* ffecom_arg_expr -- Transform argument expr into gcc tree See use by ffecom_list_expr. @@ -10935,6 +10133,51 @@ ffecom_arg_expr (ffebld expr, tree *length) } #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. + + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ + +tree +ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length) +{ + if (! expr) + return integer_zero_node; + + if (ffebld_op (expr) == FFEBLD_opANY) + { + if (length) + *length = error_mark_node; + return error_mark_node; + } + + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER + || ffebld_where (expr) == FFEINFO_whereCOMMON + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) + { + tree t; + + t = ffecom_arg_ptr_to_expr (expr, length); + assert (TREE_CONSTANT (t)); + assert (! length || TREE_CONSTANT (*length)); + return t; + } + + if (length + && ffebld_size (expr) != FFETARGET_charactersizeNONE) + *length = build_int_2 (ffebld_size (expr), 0); + else if (length) + *length = NULL_TREE; + return NULL_TREE; +} + /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree See use by ffecom_list_ptr_to_expr. @@ -11083,6 +10326,11 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) 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, @@ -11091,6 +10339,21 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) = 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; @@ -11137,11 +10400,6 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) lengths); } - sz = ffecom_concat_list_maxlen_ (catlist); - assert (sz != FFETARGET_charactersizeNONE); - - temporary = ffecom_push_tempvar (char_type_node, - sz, -1, TRUE); temporary = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (temporary)), temporary); @@ -11168,7 +10426,7 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) = build_tree_list (NULL_TREE, num); - item = ffecom_call_gfrt (FFECOM_gfrtCAT, item); + item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE); TREE_SIDE_EFFECTS (item) = 1; item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), item, @@ -11184,10 +10442,7 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) } #endif -/* ffecom_call_gfrt -- Generate call to run-time function - - tree expr; - expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE); +/* Generate call to run-time function. The first arg is the GNU Fortran Run-Time function index, the second arg is the list of arguments to pass to it. Returned is the expression @@ -11196,23 +10451,17 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_call_gfrt (ffecomGfrt ix, tree args) +ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook) { return ffecom_call_ (ffecom_gfrt_tree_ (ix), ffecom_gfrt_kindtype (ix), ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], NULL_TREE, args, NULL_TREE, NULL, - NULL, NULL_TREE, TRUE); + NULL, NULL_TREE, TRUE, hook); } #endif -/* ffecom_constantunion -- Transform constant-union to tree - - ffebldConstantUnion cu; // the constant to transform - ffeinfoBasictype bt; // its basic type - ffeinfoKindtype kt; // its kind type - tree tree_type; // ffecom_tree_type[bt][kt] - ffecom_constantunion(&cu,bt,kt,tree_type); */ +/* Transform constant-union to tree. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree @@ -11484,6 +10733,43 @@ ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, #endif +/* Transform expression into constant tree. + + If the expression can be transformed into a tree that is constant, + that is done, and the tree returned. Else NULL_TREE is returned. + + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ + +tree +ffecom_const_expr (ffebld expr) +{ + if (! expr) + return integer_zero_node; + + if (ffebld_op (expr) == FFEBLD_opANY) + return error_mark_node; + + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER +#if NEWCOMMON + /* ~~Enable once common/equivalence is handled properly? */ + || ffebld_where (expr) == FFEINFO_whereCOMMON +#endif + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) + { + tree t; + + t = ffecom_expr (expr); + assert (TREE_CONSTANT (t)); + return t; + } + + return NULL_TREE; +} + /* Handy way to make a field in a struct/union. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC @@ -11522,6 +10808,16 @@ ffecom_decode_include_option (char *spec) #endif } +/* End a compound statement (block). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_end_compstmt (void) +{ + return bison_rule_compstmt_ (); +} +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + /* ffecom_end_transition -- Perform end transition on all symbols ffecom_end_transition(); @@ -11643,11 +10939,7 @@ ffecom_exec_transition () ffebad_set_inhibit (TRUE); } -/* ffecom_expand_let_stmt -- Compile let (assignment) statement - - ffebld dest; - ffebld source; - ffecom_expand_let_stmt(dest,source); +/* Handle assignment statement. Convert dest and source using ffecom_expr, then join them with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ @@ -11665,7 +10957,28 @@ ffecom_expand_let_stmt (ffebld dest, ffebld source) { bool dest_used; - dest_tree = ffecom_expr_rw (dest); + /* This attempts to replicate the test below, but must not be + true when the test below is false. (Always err on the side + of creating unused temporaries, to avoid ICEs.) */ + if (ffebld_op (dest) != FFEBLD_opSYMTER + || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree) + && (TREE_CODE (dest_tree) != VAR_DECL + || TREE_ADDRESSABLE (dest_tree)))) + { + ffecom_prepare_expr_ (source, dest); + dest_used = TRUE; + } + else + { + ffecom_prepare_expr_ (source, NULL); + dest_used = FALSE; + } + + ffecom_prepare_expr_w (NULL_TREE, dest); + + ffecom_prepare_end (); + + dest_tree = ffecom_expr_w (NULL_TREE, dest); if (dest_tree == error_mark_node) return; @@ -11675,8 +10988,9 @@ ffecom_expand_let_stmt (ffebld dest, ffebld source) FALSE, FALSE); else { - source_tree = ffecom_expr (source); + assert (! dest_used); dest_used = FALSE; + source_tree = ffecom_expr (source); } if (source_tree == error_mark_node) return; @@ -11692,11 +11006,14 @@ ffecom_expand_let_stmt (ffebld dest, ffebld source) return; } - ffecom_push_calltemps (); + ffecom_prepare_let_char_ (ffebld_size_known (dest), source); + ffecom_prepare_expr_w (NULL_TREE, dest); + + ffecom_prepare_end (); + ffecom_char_args_ (&dest_tree, &dest_length, dest); ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), source); - ffecom_pop_calltemps (); } #endif @@ -11745,9 +11062,29 @@ ffecom_expr_assign_w (ffebld expr) #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_expr_rw (ffebld expr) +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)); +} + +#endif +/* Transform expr for use as into write tree and stabilize the + reference. Not for use on CHARACTER expressions. + + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ + +#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)); } @@ -11783,7 +11120,7 @@ ffecom_finish_decl (tree decl, tree init, bool is_top_level) void ffecom_finish_progunit () { - ffecom_end_compstmt_ (); + ffecom_end_compstmt (); ffecom_previous_function_decl_ = current_function_decl; ffecom_which_entrypoint_decl_ = NULL_TREE; @@ -11792,33 +11129,54 @@ ffecom_finish_progunit () } #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". */ +/* 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) +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); + 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 - nam = &space[0]; + { + lenlen = 0; + nam = (char *) pattern; + } + if (text == NULL) - sprintf (&nam[0], pattern, number); + { + if (number != -1) + sprintf (&nam[0], pattern, number); + } else - sprintf (&nam[0], pattern, text); + { + 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); @@ -11986,9 +11344,10 @@ ffecom_init_0 () 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 */ + /* Make the binding_level structure for global names. */ + pushlevel (0); global_binding_level = current_binding_level; + current_binding_level->prep_state = 2; /* Define `int' and `char' first so that dbx will output them first. */ @@ -12461,8 +11820,9 @@ ffecom_init_0 () 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 /* ~~~ */); + FFETARGET_f2cTYQUAD); /* CHARACTER stuff is all special-cased, so it is not handled in the above loop. CHARACTER items are built as arrays of unsigned char. */ @@ -12683,7 +12043,6 @@ ffecom_init_2 () ffecom_master_arglist_ = NULL; ++ffecom_num_fns_; - ffecom_latest_temp_ = NULL; ffecom_primary_entry_ = NULL; ffecom_is_altreturning_ = FALSE; ffecom_func_result_ = NULL_TREE; @@ -13107,65 +12466,6 @@ ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) #endif } -/* Clean up after making automatically popped call-arg temps. - - Call this in pairs with push_calltemps around calls to - ffecom_arg_ptr_to_expr if the latter might use temporaries. - Any temporaries made within the outermost sequence of - push_calltemps and pop_calltemps, that are marked as "auto-pop" - meaning they won't be explicitly popped (freed), are popped - at this point so they can be reused later. - - NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_ - should come in == 1, and all of the in-use auto-pop temps - should have DECL_CONTEXT (temp->t) == current_function_decl. - Moreover, these temps should _never_ be re-used in future - calls to ffecom_push_tempvar -- since current_function_decl will - never be the same again. - - SO, it could be a minor win in terms of compile time to just - strip these temps off the list. That is, if the above assumptions - are correct, just remove from the list of temps any temp - that is both in-use and has DECL_CONTEXT (temp->t) - == current_function_decl, when called from ffecom_gen_sfuncdef_. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_pop_calltemps () -{ - ffecomTemp_ temp; - - assert (ffecom_pending_calls_ > 0); - - if (--ffecom_pending_calls_ == 0) - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - if (temp->auto_pop) - temp->in_use = FALSE; -} - -#endif -/* Mark latest temp with given tree as no longer in use. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_pop_tempvar (tree t) -{ - ffecomTemp_ temp; - - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - if (temp->in_use && (temp->t == t)) - { - assert (!temp->auto_pop); - temp->in_use = FALSE; - return; - } - else - assert (temp->t != t); - - assert ("couldn't ffecom_pop_tempvar!" != NULL); -} - -#endif /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front tree t; @@ -13229,7 +12529,7 @@ ffecom_ptr_to_expr (ffebld expr) if (item == error_mark_node) return item; - if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) + if ((ffebld_where (expr) == FFEINFO_whereFLEETING) && !mark_addressable (item)) return error_mark_node; /* Make sure non-const ref is to non-reg. */ @@ -13281,8 +12581,6 @@ ffecom_ptr_to_expr (ffebld expr) return error_mark_node; default: - assert (ffecom_pending_calls_ > 0); - bt = ffeinfo_basictype (ffebld_info (expr)); kt = ffeinfo_kindtype (ffebld_info (expr)); @@ -13322,60 +12620,27 @@ ffecom_ptr_to_expr (ffebld expr) } #endif -/* Prepare to make call-arg temps. - - Call this in pairs with pop_calltemps around calls to - ffecom_arg_ptr_to_expr if the latter might use temporaries. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_push_calltemps () -{ - ffecom_pending_calls_++; -} - -#endif /* Obtain a temp var with given data type. - Returns a VAR_DECL tree of a currently (that is, at the current - statement being compiled) not in use and having the given data type, - making a new one if necessary. size is FFETARGET_charactersizeNONE - for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is - -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if - ffecom_pop_tempvar won't be called, meaning temp will be freed - when #pending calls goes to zero. */ + 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. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements, - bool auto_pop) +ffecom_make_tempvar (const char *commentary, tree type, + ffetargetCharacterSize size, int elements) { - ffecomTemp_ temp; int yes; tree t; static int mynumber; - assert (!auto_pop || (ffecom_pending_calls_ > 0)); + assert (current_binding_level->prep_state < 2); if (type == error_mark_node) return error_mark_node; - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - { - if (temp->in_use - || (temp->type != type) - || (temp->size != size) - || (temp->elements != elements) - || (DECL_CONTEXT (temp->t) != current_function_decl)) - continue; - - temp->in_use = TRUE; - temp->auto_pop = auto_pop; - return temp->t; - } - - /* Create a new temp. */ - yes = suspend_momentary (); if (size != FFETARGET_charactersizeNONE) @@ -13390,42 +12655,369 @@ ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements, build_int_2 (elements - 1, 0))); t = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_expr_%d", NULL, + ffecom_get_invented_identifier ("__g77_%s_%d", + commentary, mynumber++), type); - /* 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 (); - t = start_decl (t, FALSE); finish_decl (t, NULL_TREE, FALSE); - pop_topmost_sequence (); - resume_momentary (yes); - temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_", - sizeof (*temp)); + return t; +} +#endif - 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; +/* Prepare argument pointer to expression. - ffecom_latest_temp_ = temp; + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_arg_ptr_to_expr. */ - return t; +void +ffecom_prepare_arg_ptr_to_expr (ffebld expr) +{ + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} + +/* End of preparations. */ + +bool +ffecom_prepare_end (void) +{ + int prep_state = current_binding_level->prep_state; + + assert (prep_state < 2); + current_binding_level->prep_state = 2; + + return (prep_state == 1) ? TRUE : FALSE; +} + +/* Prepare expression. + + This is called before any code is generated for the current block. + It scans the expression, declares any temporaries that might be needed + during evaluation of the expression, and stores those temporaries in + the appropriate "hook" fields of the expression. `dest', if not NULL, + specifies the destination that ffecom_expr_ will see, in case that + helps avoid generating unused temporaries. + + ~~Improve to avoid allocating unused temporaries by taking `dest' + into account vis-a-vis aliasing requirements of complex/character + functions. */ + +void +ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) +{ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize sz; + tree tempvar = NULL_TREE; + + assert (current_binding_level->prep_state < 2); + + if (! expr) + return; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + sz = ffeinfo_size (ffebld_info (expr)); + + /* Generate whatever temporaries are needed to represent the result + of the expression. */ + + switch (ffebld_op (expr)) + { + default: + /* Don't make temps for SYMTER, CONTER, etc. */ + if (ffebld_arity (expr) == 0) + break; + + switch (bt) + { + case FFEINFO_basictypeCOMPLEX: + if (ffebld_op (expr) == FFEBLD_opFUNCREF) + { + ffesymbol s; + + if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER) + break; + + s = ffebld_symter (ffebld_left (expr)); + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT + || ! ffesymbol_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 FFEINFO_basictypeCHARACTER: + if (ffebld_op (expr) != FFEBLD_opFUNCREF) + break; + + if (sz == FFETARGET_charactersizeNONE) + /* ~~Kludge alert! This should someday be fixed. */ + sz = 24; + + tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1); + break; + + default: + break; + } + break; + +#ifdef HAHA + case FFEBLD_opPOWER: + { + tree rtype, ltype; + tree rtmp, ltmp, result; + + ltype = ffecom_type_expr (ffebld_left (expr)); + rtype = ffecom_type_expr (ffebld_right (expr)); + + rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1); + ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); + result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); + + 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 */ + + case FFEBLD_opCONCATENATE: + { + /* This gets special handling, because only one set of temps + is needed for a tree of these -- the tree is treated as + a flattened list of concatenations when generating code. */ + + ffecomConcatList_ catlist; + tree ltmp, itmp, result; + int count; + int i; + + catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); + count = ffecom_concat_list_count_ (catlist); + + if (count >= 2) + { + ltmp + = ffecom_make_tempvar ("concat_len", + ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count); + itmp + = ffecom_make_tempvar ("concat_item", + ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count); + result + = ffecom_make_tempvar ("concat_res", + char_type_node, + ffecom_concat_list_maxlen_ (catlist), + -1); + + tempvar = make_tree_vec (3); + TREE_VEC_ELT (tempvar, 0) = ltmp; + TREE_VEC_ELT (tempvar, 1) = itmp; + TREE_VEC_ELT (tempvar, 2) = result; + } + + for (i = 0; i < count; ++i) + ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, + i)); + + ffecom_concat_list_kill_ (catlist); + + if (tempvar) + { + ffebld_nonter_set_hook (expr, tempvar); + current_binding_level->prep_state = 1; + } + } + return; + + case FFEBLD_opCONVERT: + if (bt == FFEINFO_basictypeCHARACTER + && ((ffebld_size_known (ffebld_left (expr)) + == FFETARGET_charactersizeNONE) + || (ffebld_size_known (ffebld_left (expr)) >= sz))) + tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1); + break; + } + + if (tempvar) + { + ffebld_nonter_set_hook (expr, tempvar); + current_binding_level->prep_state = 1; + } + + /* Prepare subexpressions for this expr. */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opPERCENT_LOC: + ffecom_prepare_ptr_to_expr (ffebld_left (expr)); + break; + + case FFEBLD_opPERCENT_VAL: + case FFEBLD_opPERCENT_REF: + ffecom_prepare_expr (ffebld_left (expr)); + break; + + case FFEBLD_opPERCENT_DESCR: + ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr)); + break; + + case FFEBLD_opITEM: + { + ffebld item; + + for (item = expr; + item != NULL; + item = ffebld_trail (item)) + if (ffebld_head (item) != NULL) + ffecom_prepare_expr (ffebld_head (item)); + } + break; + + default: + /* Need to handle character conversion specially. */ + switch (ffebld_arity (expr)) + { + case 2: + ffecom_prepare_expr (ffebld_left (expr)); + ffecom_prepare_expr (ffebld_right (expr)); + break; + + case 1: + ffecom_prepare_expr (ffebld_left (expr)); + break; + + default: + break; + } + } + + return; +} + +/* Prepare expression for reading and writing. + + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_expr_rw. */ + +void +ffecom_prepare_expr_rw (tree type, ffebld expr) +{ + /* This is all we support for now. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); + + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} + +/* Prepare expression for writing. + + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_expr_w. */ + +void +ffecom_prepare_expr_w (tree type, ffebld expr) +{ + /* This is all we support for now. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); + + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} + +/* Prepare expression for returning. + + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_return_expr. */ + +void +ffecom_prepare_return_expr (ffebld expr) +{ + assert (current_binding_level->prep_state < 2); + + if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE + && ffecom_is_altreturning_ + && expr != NULL) + ffecom_prepare_expr (expr); +} + +/* Prepare pointer to expression. + + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_ptr_to_expr. */ + +void +ffecom_prepare_ptr_to_expr (ffebld expr) +{ + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} + +/* Transform expression into constant pointer-to-expression tree. + + If the expression can be transformed into a pointer-to-expression tree + that is constant, that is done, and the tree returned. Else NULL_TREE + is returned. + + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ + +tree +ffecom_ptr_to_const_expr (ffebld expr) +{ + if (! expr) + return integer_zero_node; + + if (ffebld_op (expr) == FFEBLD_opANY) + return error_mark_node; + + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER + || ffebld_where (expr) == FFEINFO_whereCOMMON + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) + { + tree t; + + t = ffecom_ptr_to_expr (expr); + assert (TREE_CONSTANT (t)); + return t; + } + + return NULL_TREE; } -#endif /* ffecom_return_expr -- Returns return-value expr given alt return expr tree rtn; // NULL_TREE means use expand_null_return() @@ -13521,6 +13113,16 @@ ffecom_save_tree (tree t) } #endif +/* Start a compound statement (block). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_start_compstmt (void) +{ + bison_rule_pushlevel_ (); +} +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + /* Public entry point for front end to access start_decl. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC @@ -13765,6 +13367,74 @@ ffecom_truth_value_invert (tree expr) } #endif + +/* Return the tree that is the type of the expression, as would be + returned in TREE_TYPE(ffecom_expr(expr)), without otherwise + transforming the expression, generating temporaries, etc. */ + +tree +ffecom_type_expr (ffebld expr) +{ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree tree_type; + + assert (expr != NULL); + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + tree_type = ffecom_tree_type[bt][kt]; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opUPLUS: + case FFEBLD_opPAREN: + case FFEBLD_opUMINUS: + case FFEBLD_opADD: + case FFEBLD_opSUBTRACT: + case FFEBLD_opMULTIPLY: + case FFEBLD_opDIVIDE: + case FFEBLD_opPOWER: + case FFEBLD_opNOT: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBRREF: + case FFEBLD_opAND: + case FFEBLD_opOR: + case FFEBLD_opXOR: + case FFEBLD_opNEQV: + case FFEBLD_opEQV: + case FFEBLD_opCONVERT: + case FFEBLD_opLT: + case FFEBLD_opLE: + case FFEBLD_opEQ: + case FFEBLD_opNE: + case FFEBLD_opGT: + case FFEBLD_opGE: + case FFEBLD_opPERCENT_LOC: + return tree_type; + + case FFEBLD_opACCTER: + case FFEBLD_opARRTER: + case FFEBLD_opITEM: + case FFEBLD_opSTAR: + case FFEBLD_opBOUNDS: + case FFEBLD_opREPEAT: + case FFEBLD_opLABTER: + case FFEBLD_opLABTOK: + case FFEBLD_opIMPDO: + case FFEBLD_opCONCATENATE: + case FFEBLD_opSUBSTR: + default: + assert ("bad op for ffecom_type_expr" == NULL); + /* Fall through. */ + case FFEBLD_opANY: + return error_mark_node; + } +} + /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points If the PARM_DECL already exists, return it, else create it. It's an @@ -13802,15 +13472,6 @@ ffecom_which_entrypoint_decl () #if FFECOM_targetCURRENT == FFECOM_targetGCC static void -bison_rule_compstmt_ () -{ - emit_line_note (input_filename, lineno); - expand_end_bindings (getdecls (), 1, 1); - poplevel (1, 1, 0); - pop_momentary (); -} - -static void bison_rule_pushlevel_ () { emit_line_note (input_filename, lineno); @@ -13820,6 +13481,24 @@ bison_rule_pushlevel_ () expand_start_bindings (0); } +static tree +bison_rule_compstmt_ () +{ + tree t; + int keep = kept_level_p (); + + /* Make the temps go away. */ + if (! keep) + current_binding_level->names = NULL_TREE; + + emit_line_note (input_filename, lineno); + expand_end_bindings (getdecls (), keep, 0); + t = poplevel (keep, 1, 0); + pop_momentary (); + + return t; +} + /* Return a definition for a builtin function named NAME and whose data type is TYPE. TYPE should be a function type with argument types. FUNCTION_CODE tells later passes how to compile calls to this function. @@ -14802,6 +14481,7 @@ start_function (tree name, tree type, int nested, int public) ffecom_outer_function_decl_ = current_function_decl; pushlevel (0); + current_binding_level->prep_state = 2; if (TREE_CODE (current_function_decl) != ERROR_MARK) { @@ -14894,9 +14574,9 @@ global_bindings_p () return current_binding_level == global_binding_level; } -/* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside the BIND_EXPR. */ +/* 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. */ void incomplete_type_error (value, type) @@ -14955,6 +14635,30 @@ 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; @@ -15107,17 +14811,17 @@ poplevel (keep, reverse, functionbody) int functionbody; { register tree link; - /* The chain of decls was accumulated in reverse order. Put it into forward - order, just for cleanliness. */ + /* The chain of decls was accumulated in reverse order. + Put it into forward order, just for cleanliness. */ tree decls; tree subblocks = current_binding_level->blocks; tree block = 0; tree decl; int block_previously_created; - /* Get the decls in the order they were written. Usually - current_binding_level->names is in reverse order. But parameter decls - were previously put in forward order. */ + /* Get the decls in the order they were written. + Usually current_binding_level->names is in reverse order. + But parameter decls were previously put in forward order. */ if (reverse) current_binding_level->names @@ -15125,21 +14829,25 @@ poplevel (keep, reverse, functionbody) else decls = current_binding_level->names; - /* Output any nested inline functions within this block if they weren't - already output. */ + /* Output any nested inline functions within this block + if they weren't already output. */ for (decl = decls; decl; decl = TREE_CHAIN (decl)) if (TREE_CODE (decl) == FUNCTION_DECL - && !TREE_ASM_WRITTEN (decl) + && ! 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) + /* 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 + else if (DECL_SAVED_INSNS (decl) != 0) { push_function_context (); output_inline_function (decl); @@ -15147,9 +14855,9 @@ poplevel (keep, reverse, functionbody) } } - /* 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. */ + /* If there were any declarations or structure tags in that level, + or if this level is a function body, + create a BLOCK to record them for the life of this function. */ block = 0; block_previously_created = (current_binding_level->this_block != 0); @@ -15188,15 +14896,16 @@ poplevel (keep, reverse, functionbody) } } - /* 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 the level being exited is the top level of a function, + check over all the labels, and clear out the current + (function local) meanings of their names. */ if (functionbody) { - /* If this is the top level block of a function, the vars are the - function's parameters. Don't leave them in the BLOCK because they - are found in the FUNCTION_DECL instead. */ + /* 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; } @@ -15221,28 +14930,15 @@ poplevel (keep, reverse, functionbody) 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. */ + /* If we did not make a block for the level just exited, + any blocks made for inner levels + (since they cannot be recorded as subblocks in that level) + must be carried forward so they will later become subblocks + of something else. */ else if (subblocks) current_binding_level->blocks = chainon (current_binding_level->blocks, subblocks); - /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this - binding contour so that they point to the appropriate construct, i.e. - either to the current FUNCTION_DECL node, or else to the BLOCK node we - just constructed. - - Note that for tagged types whose scope is just the formal parameter list - for some function type specification, we can't properly set their - TYPE_CONTEXTs here, because we don't have a pointer to the appropriate - FUNCTION_TYPE node readily available to us. For those cases, the - TYPE_CONTEXTs of the relevant tagged type nodes get set in - `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which - will represent the "scope" for these "parameter list local" tagged - types. */ - if (block) TREE_USED (block) = 1; return block; @@ -15398,6 +15094,27 @@ pushdecl (x) return x; } +/* Nonzero if the current level needs to have a BLOCK made. */ + +static int +kept_level_p () +{ + tree decl; + + for (decl = current_binding_level->names; + decl; + decl = TREE_CHAIN (decl)) + { + if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL + || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl))) + /* Currently, there aren't supposed to be non-artificial names + at other than the top block for a function -- they're + believed to always be temps. But it's wise to check anyway. */ + return 1; + } + return 0; +} + /* Enter a new binding level. If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, not for that of tags. */ @@ -15408,7 +15125,12 @@ pushlevel (tag_transparent) { register struct binding_level *newlevel = NULL_BINDING_LEVEL; - assert (!tag_transparent); + assert (! tag_transparent); + + if (current_binding_level == global_binding_level) + { + named_labels = 0; + } /* Reuse or create a struct for this binding level. */ @@ -15422,8 +15144,8 @@ pushlevel (tag_transparent) newlevel = make_binding_level (); } - /* Add this level to the front of the chain (stack) of levels that are - active. */ + /* Add this level to the front of the chain (stack) of levels that + are active. */ *newlevel = clear_binding_level; newlevel->level_chain = current_binding_level; @@ -15440,7 +15162,7 @@ set_block (block) current_binding_level->this_block = block; } -/* ~~tree.h SHOULD declare this, because toplev.c references it. */ +/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */ /* Can't 'yydebug' a front end not generated by yacc/bison! */ @@ -16523,3 +16245,877 @@ ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) return f; } #endif /* FFECOM_GCC_INCLUDE */ + +/**INDENT* (Do not reformat this comment even with -fca option.) + Data-gathering files: Given the source file listed below, compiled with + f2c I obtained the output file listed after that, and from the output + file I derived the above code. + +-------- (begin input file to f2c) + implicit none + character*10 A1,A2 + complex C1,C2 + integer I1,I2 + real R1,R2 + double precision D1,D2 +C + call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) +c / + call fooI(I1/I2) + call fooR(R1/I1) + call fooD(D1/I1) + call fooC(C1/I1) + call fooR(R1/R2) + call fooD(R1/D1) + call fooD(D1/D2) + call fooD(D1/R1) + call fooC(C1/C2) + call fooC(C1/R1) + call fooZ(C1/D1) +c ** + call fooI(I1**I2) + call fooR(R1**I1) + call fooD(D1**I1) + call fooC(C1**I1) + call fooR(R1**R2) + call fooD(R1**D1) + call fooD(D1**D2) + call fooD(D1**R1) + call fooC(C1**C2) + call fooC(C1**R1) + call fooZ(C1**D1) +c FFEINTRIN_impABS + call fooR(ABS(R1)) +c FFEINTRIN_impACOS + call fooR(ACOS(R1)) +c FFEINTRIN_impAIMAG + call fooR(AIMAG(C1)) +c FFEINTRIN_impAINT + call fooR(AINT(R1)) +c FFEINTRIN_impALOG + call fooR(ALOG(R1)) +c FFEINTRIN_impALOG10 + call fooR(ALOG10(R1)) +c FFEINTRIN_impAMAX0 + call fooR(AMAX0(I1,I2)) +c FFEINTRIN_impAMAX1 + call fooR(AMAX1(R1,R2)) +c FFEINTRIN_impAMIN0 + call fooR(AMIN0(I1,I2)) +c FFEINTRIN_impAMIN1 + call fooR(AMIN1(R1,R2)) +c FFEINTRIN_impAMOD + call fooR(AMOD(R1,R2)) +c FFEINTRIN_impANINT + call fooR(ANINT(R1)) +c FFEINTRIN_impASIN + call fooR(ASIN(R1)) +c FFEINTRIN_impATAN + call fooR(ATAN(R1)) +c FFEINTRIN_impATAN2 + call fooR(ATAN2(R1,R2)) +c FFEINTRIN_impCABS + call fooR(CABS(C1)) +c FFEINTRIN_impCCOS + call fooC(CCOS(C1)) +c FFEINTRIN_impCEXP + call fooC(CEXP(C1)) +c FFEINTRIN_impCHAR + call fooA(CHAR(I1)) +c FFEINTRIN_impCLOG + call fooC(CLOG(C1)) +c FFEINTRIN_impCONJG + call fooC(CONJG(C1)) +c FFEINTRIN_impCOS + call fooR(COS(R1)) +c FFEINTRIN_impCOSH + call fooR(COSH(R1)) +c FFEINTRIN_impCSIN + call fooC(CSIN(C1)) +c FFEINTRIN_impCSQRT + call fooC(CSQRT(C1)) +c FFEINTRIN_impDABS + call fooD(DABS(D1)) +c FFEINTRIN_impDACOS + call fooD(DACOS(D1)) +c FFEINTRIN_impDASIN + call fooD(DASIN(D1)) +c FFEINTRIN_impDATAN + call fooD(DATAN(D1)) +c FFEINTRIN_impDATAN2 + call fooD(DATAN2(D1,D2)) +c FFEINTRIN_impDCOS + call fooD(DCOS(D1)) +c FFEINTRIN_impDCOSH + call fooD(DCOSH(D1)) +c FFEINTRIN_impDDIM + call fooD(DDIM(D1,D2)) +c FFEINTRIN_impDEXP + call fooD(DEXP(D1)) +c FFEINTRIN_impDIM + call fooR(DIM(R1,R2)) +c FFEINTRIN_impDINT + call fooD(DINT(D1)) +c FFEINTRIN_impDLOG + call fooD(DLOG(D1)) +c FFEINTRIN_impDLOG10 + call fooD(DLOG10(D1)) +c FFEINTRIN_impDMAX1 + call fooD(DMAX1(D1,D2)) +c FFEINTRIN_impDMIN1 + call fooD(DMIN1(D1,D2)) +c FFEINTRIN_impDMOD + call fooD(DMOD(D1,D2)) +c FFEINTRIN_impDNINT + call fooD(DNINT(D1)) +c FFEINTRIN_impDPROD + call fooD(DPROD(R1,R2)) +c FFEINTRIN_impDSIGN + call fooD(DSIGN(D1,D2)) +c FFEINTRIN_impDSIN + call fooD(DSIN(D1)) +c FFEINTRIN_impDSINH + call fooD(DSINH(D1)) +c FFEINTRIN_impDSQRT + call fooD(DSQRT(D1)) +c FFEINTRIN_impDTAN + call fooD(DTAN(D1)) +c FFEINTRIN_impDTANH + call fooD(DTANH(D1)) +c FFEINTRIN_impEXP + call fooR(EXP(R1)) +c FFEINTRIN_impIABS + call fooI(IABS(I1)) +c FFEINTRIN_impICHAR + call fooI(ICHAR(A1)) +c FFEINTRIN_impIDIM + call fooI(IDIM(I1,I2)) +c FFEINTRIN_impIDNINT + call fooI(IDNINT(D1)) +c FFEINTRIN_impINDEX + call fooI(INDEX(A1,A2)) +c FFEINTRIN_impISIGN + call fooI(ISIGN(I1,I2)) +c FFEINTRIN_impLEN + call fooI(LEN(A1)) +c FFEINTRIN_impLGE + call fooL(LGE(A1,A2)) +c FFEINTRIN_impLGT + call fooL(LGT(A1,A2)) +c FFEINTRIN_impLLE + call fooL(LLE(A1,A2)) +c FFEINTRIN_impLLT + call fooL(LLT(A1,A2)) +c FFEINTRIN_impMAX0 + call fooI(MAX0(I1,I2)) +c FFEINTRIN_impMAX1 + call fooI(MAX1(R1,R2)) +c FFEINTRIN_impMIN0 + call fooI(MIN0(I1,I2)) +c FFEINTRIN_impMIN1 + call fooI(MIN1(R1,R2)) +c FFEINTRIN_impMOD + call fooI(MOD(I1,I2)) +c FFEINTRIN_impNINT + call fooI(NINT(R1)) +c FFEINTRIN_impSIGN + call fooR(SIGN(R1,R2)) +c FFEINTRIN_impSIN + call fooR(SIN(R1)) +c FFEINTRIN_impSINH + call fooR(SINH(R1)) +c FFEINTRIN_impSQRT + call fooR(SQRT(R1)) +c FFEINTRIN_impTAN + call fooR(TAN(R1)) +c FFEINTRIN_impTANH + call fooR(TANH(R1)) +c FFEINTRIN_imp_CMPLX_C + call fooC(cmplx(C1,C2)) +c FFEINTRIN_imp_CMPLX_D + call fooZ(cmplx(D1,D2)) +c FFEINTRIN_imp_CMPLX_I + call fooC(cmplx(I1,I2)) +c FFEINTRIN_imp_CMPLX_R + call fooC(cmplx(R1,R2)) +c FFEINTRIN_imp_DBLE_C + call fooD(dble(C1)) +c FFEINTRIN_imp_DBLE_D + call fooD(dble(D1)) +c FFEINTRIN_imp_DBLE_I + call fooD(dble(I1)) +c FFEINTRIN_imp_DBLE_R + call fooD(dble(R1)) +c FFEINTRIN_imp_INT_C + call fooI(int(C1)) +c FFEINTRIN_imp_INT_D + call fooI(int(D1)) +c FFEINTRIN_imp_INT_I + call fooI(int(I1)) +c FFEINTRIN_imp_INT_R + call fooI(int(R1)) +c FFEINTRIN_imp_REAL_C + call fooR(real(C1)) +c FFEINTRIN_imp_REAL_D + call fooR(real(D1)) +c FFEINTRIN_imp_REAL_I + call fooR(real(I1)) +c FFEINTRIN_imp_REAL_R + call fooR(real(R1)) +c +c FFEINTRIN_imp_INT_D: +c +c FFEINTRIN_specIDINT + call fooI(IDINT(D1)) +c +c FFEINTRIN_imp_INT_R: +c +c FFEINTRIN_specIFIX + call fooI(IFIX(R1)) +c FFEINTRIN_specINT + call fooI(INT(R1)) +c +c FFEINTRIN_imp_REAL_D: +c +c FFEINTRIN_specSNGL + call fooR(SNGL(D1)) +c +c FFEINTRIN_imp_REAL_I: +c +c FFEINTRIN_specFLOAT + call fooR(FLOAT(I1)) +c FFEINTRIN_specREAL + call fooR(REAL(I1)) +c + end +-------- (end input file to f2c) + +-------- (begin output from providing above input file as input to: +-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ +-------- -e "s:^#.*$::g"') + +// -- translated by f2c (version 19950223). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +// + + +// f2c.h -- Standard Fortran to C header file // + +/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // + + + + +// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // +// we assume short, float are OK // +typedef long int // long int // integer; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int // long int // logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +// typedef long long longint; // // system-dependent // + + + + +// Extern is for use with -E // + + + + +// I/O stuff // + + + + + + + + +typedef long int // int or long int // flag; +typedef long int // int or long int // ftnlen; +typedef long int // int or long int // ftnint; + + +//external read, write// +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +//internal read, write// +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +//open// +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +//close// +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +//rewind, backspace, endfile// +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +// inquire // +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; //parameters in standard's order// + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + + + +union Multitype { // for multiple entry points // + integer1 g; + shortint h; + integer i; + // longint j; // + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +typedef long Long; // No longer used; formerly in Namelist // + +struct Vardesc { // for Namelist // + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + + + + + + + + +// procedure parameter types for -A and -C++ // + + + + +typedef int // Unknown procedure type // (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef // Complex // void (*C_fp)(); +typedef // Double Complex // void (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef // Character // void (*H_fp)(); +typedef // Subroutine // int (*S_fp)(); + +// E_fp is for real functions when -R is not specified // +typedef void C_f; // complex function // +typedef void H_f; // character function // +typedef void Z_f; // double complex function // +typedef doublereal E_f; // real function with -R not specified // + +// undef any lower-case symbols that your C compiler predefines, e.g.: // + + +// (No such symbols should be defined in a strict ANSI C compiler. + We can avoid trouble with f2c-translated code by using + gcc -ansi [-traditional].) // + + + + + + + + + + + + + + + + + + + + + + + +// Main program // MAIN__() +{ + // System generated locals // + integer i__1; + real r__1, r__2; + doublereal d__1, d__2; + complex q__1; + doublecomplex z__1, z__2, z__3; + logical L__1; + char ch__1[1]; + + // Builtin functions // + void c_div(); + integer pow_ii(); + double pow_ri(), pow_di(); + void pow_ci(); + double pow_dd(); + void pow_zz(); + double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), + asin(), atan(), atan2(), c_abs(); + void c_cos(), c_exp(), c_log(), r_cnjg(); + double cos(), cosh(); + void c_sin(), c_sqrt(); + double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), + d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); + integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); + logical l_ge(), l_gt(), l_le(), l_lt(); + integer i_nint(); + double r_sign(); + + // Local variables // + extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), + fool_(), fooz_(), getem_(); + static char a1[10], a2[10]; + static complex c1, c2; + static doublereal d1, d2; + static integer i1, i2; + static real r1, r2; + + + getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); +// / // + i__1 = i1 / i2; + fooi_(&i__1); + r__1 = r1 / i1; + foor_(&r__1); + d__1 = d1 / i1; + food_(&d__1); + d__1 = (doublereal) i1; + q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; + fooc_(&q__1); + r__1 = r1 / r2; + foor_(&r__1); + d__1 = r1 / d1; + food_(&d__1); + d__1 = d1 / d2; + food_(&d__1); + d__1 = d1 / r1; + food_(&d__1); + c_div(&q__1, &c1, &c2); + fooc_(&q__1); + q__1.r = c1.r / r1, q__1.i = c1.i / r1; + fooc_(&q__1); + z__1.r = c1.r / d1, z__1.i = c1.i / d1; + fooz_(&z__1); +// ** // + i__1 = pow_ii(&i1, &i2); + fooi_(&i__1); + r__1 = pow_ri(&r1, &i1); + foor_(&r__1); + d__1 = pow_di(&d1, &i1); + food_(&d__1); + pow_ci(&q__1, &c1, &i1); + fooc_(&q__1); + d__1 = (doublereal) r1; + d__2 = (doublereal) r2; + r__1 = pow_dd(&d__1, &d__2); + foor_(&r__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d__2, &d1); + food_(&d__1); + d__1 = pow_dd(&d1, &d2); + food_(&d__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d1, &d__2); + food_(&d__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = c2.r, z__3.i = c2.i; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = r1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = d1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + fooz_(&z__1); +// FFEINTRIN_impABS // + r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; + foor_(&r__1); +// FFEINTRIN_impACOS // + r__1 = acos(r1); + foor_(&r__1); +// FFEINTRIN_impAIMAG // + r__1 = r_imag(&c1); + foor_(&r__1); +// FFEINTRIN_impAINT // + r__1 = r_int(&r1); + foor_(&r__1); +// FFEINTRIN_impALOG // + r__1 = log(r1); + foor_(&r__1); +// FFEINTRIN_impALOG10 // + r__1 = r_lg10(&r1); + foor_(&r__1); +// FFEINTRIN_impAMAX0 // + r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMAX1 // + r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN0 // + r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN1 // + r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMOD // + r__1 = r_mod(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impANINT // + r__1 = r_nint(&r1); + foor_(&r__1); +// FFEINTRIN_impASIN // + r__1 = asin(r1); + foor_(&r__1); +// FFEINTRIN_impATAN // + r__1 = atan(r1); + foor_(&r__1); +// FFEINTRIN_impATAN2 // + r__1 = atan2(r1, r2); + foor_(&r__1); +// FFEINTRIN_impCABS // + r__1 = c_abs(&c1); + foor_(&r__1); +// FFEINTRIN_impCCOS // + c_cos(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCEXP // + c_exp(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCHAR // + *(unsigned char *)&ch__1[0] = i1; + fooa_(ch__1, 1L); +// FFEINTRIN_impCLOG // + c_log(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCONJG // + r_cnjg(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCOS // + r__1 = cos(r1); + foor_(&r__1); +// FFEINTRIN_impCOSH // + r__1 = cosh(r1); + foor_(&r__1); +// FFEINTRIN_impCSIN // + c_sin(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCSQRT // + c_sqrt(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impDABS // + d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; + food_(&d__1); +// FFEINTRIN_impDACOS // + d__1 = acos(d1); + food_(&d__1); +// FFEINTRIN_impDASIN // + d__1 = asin(d1); + food_(&d__1); +// FFEINTRIN_impDATAN // + d__1 = atan(d1); + food_(&d__1); +// FFEINTRIN_impDATAN2 // + d__1 = atan2(d1, d2); + food_(&d__1); +// FFEINTRIN_impDCOS // + d__1 = cos(d1); + food_(&d__1); +// FFEINTRIN_impDCOSH // + d__1 = cosh(d1); + food_(&d__1); +// FFEINTRIN_impDDIM // + d__1 = d_dim(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDEXP // + d__1 = exp(d1); + food_(&d__1); +// FFEINTRIN_impDIM // + r__1 = r_dim(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impDINT // + d__1 = d_int(&d1); + food_(&d__1); +// FFEINTRIN_impDLOG // + d__1 = log(d1); + food_(&d__1); +// FFEINTRIN_impDLOG10 // + d__1 = d_lg10(&d1); + food_(&d__1); +// FFEINTRIN_impDMAX1 // + d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMIN1 // + d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMOD // + d__1 = d_mod(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDNINT // + d__1 = d_nint(&d1); + food_(&d__1); +// FFEINTRIN_impDPROD // + d__1 = (doublereal) r1 * r2; + food_(&d__1); +// FFEINTRIN_impDSIGN // + d__1 = d_sign(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDSIN // + d__1 = sin(d1); + food_(&d__1); +// FFEINTRIN_impDSINH // + d__1 = sinh(d1); + food_(&d__1); +// FFEINTRIN_impDSQRT // + d__1 = sqrt(d1); + food_(&d__1); +// FFEINTRIN_impDTAN // + d__1 = tan(d1); + food_(&d__1); +// FFEINTRIN_impDTANH // + d__1 = tanh(d1); + food_(&d__1); +// FFEINTRIN_impEXP // + r__1 = exp(r1); + foor_(&r__1); +// FFEINTRIN_impIABS // + i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; + fooi_(&i__1); +// FFEINTRIN_impICHAR // + i__1 = *(unsigned char *)a1; + fooi_(&i__1); +// FFEINTRIN_impIDIM // + i__1 = i_dim(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impIDNINT // + i__1 = i_dnnt(&d1); + fooi_(&i__1); +// FFEINTRIN_impINDEX // + i__1 = i_indx(a1, a2, 10L, 10L); + fooi_(&i__1); +// FFEINTRIN_impISIGN // + i__1 = i_sign(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impLEN // + i__1 = i_len(a1, 10L); + fooi_(&i__1); +// FFEINTRIN_impLGE // + L__1 = l_ge(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLGT // + L__1 = l_gt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLE // + L__1 = l_le(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLT // + L__1 = l_lt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impMAX0 // + i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMAX1 // + i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN0 // + i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN1 // + i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMOD // + i__1 = i1 % i2; + fooi_(&i__1); +// FFEINTRIN_impNINT // + i__1 = i_nint(&r1); + fooi_(&i__1); +// FFEINTRIN_impSIGN // + r__1 = r_sign(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impSIN // + r__1 = sin(r1); + foor_(&r__1); +// FFEINTRIN_impSINH // + r__1 = sinh(r1); + foor_(&r__1); +// FFEINTRIN_impSQRT // + r__1 = sqrt(r1); + foor_(&r__1); +// FFEINTRIN_impTAN // + r__1 = tan(r1); + foor_(&r__1); +// FFEINTRIN_impTANH // + r__1 = tanh(r1); + foor_(&r__1); +// FFEINTRIN_imp_CMPLX_C // + r__1 = c1.r; + r__2 = c2.r; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_D // + z__1.r = d1, z__1.i = d2; + fooz_(&z__1); +// FFEINTRIN_imp_CMPLX_I // + r__1 = (real) i1; + r__2 = (real) i2; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_R // + q__1.r = r1, q__1.i = r2; + fooc_(&q__1); +// FFEINTRIN_imp_DBLE_C // + d__1 = (doublereal) c1.r; + food_(&d__1); +// FFEINTRIN_imp_DBLE_D // + d__1 = d1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_I // + d__1 = (doublereal) i1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_R // + d__1 = (doublereal) r1; + food_(&d__1); +// FFEINTRIN_imp_INT_C // + i__1 = (integer) c1.r; + fooi_(&i__1); +// FFEINTRIN_imp_INT_D // + i__1 = (integer) d1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_I // + i__1 = i1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_R // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_imp_REAL_C // + r__1 = c1.r; + foor_(&r__1); +// FFEINTRIN_imp_REAL_D // + r__1 = (real) d1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_I // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_R // + r__1 = r1; + foor_(&r__1); + +// FFEINTRIN_imp_INT_D: // + +// FFEINTRIN_specIDINT // + i__1 = (integer) d1; + fooi_(&i__1); + +// FFEINTRIN_imp_INT_R: // + +// FFEINTRIN_specIFIX // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_specINT // + i__1 = (integer) r1; + fooi_(&i__1); + +// FFEINTRIN_imp_REAL_D: // + +// FFEINTRIN_specSNGL // + r__1 = (real) d1; + foor_(&r__1); + +// FFEINTRIN_imp_REAL_I: // + +// FFEINTRIN_specFLOAT // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_specREAL // + r__1 = (real) i1; + foor_(&r__1); + +} // MAIN__ // + +-------- (end output file from f2c) + +*/ diff --git a/gcc/f/com.h b/gcc/f/com.h index a438d0b..baa2953 100644 --- a/gcc/f/com.h +++ b/gcc/f/com.h @@ -56,6 +56,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA #if FFECOM_targetCURRENT == FFECOM_targetGCC #define FFECOM_constantNULL NULL_TREE +#define FFECOM_nonterNULL NULL_TREE #define FFECOM_globalNULL NULL_TREE #define FFECOM_labelNULL NULL_TREE #define FFECOM_storageNULL NULL_TREE @@ -202,6 +203,8 @@ typedef enum typedef tree ffecomConstant; #define FFECOM_constantHOOK +typedef tree ffecomNonter; +#define FFECOM_nonterHOOK typedef tree ffecomLabel; #define FFECOM_globalHOOK typedef tree ffecomGlobal; @@ -279,15 +282,20 @@ tree ffecom_3 (enum tree_code code, tree type, tree node1, tree node2, tree ffecom_3s (enum tree_code code, tree type, tree node1, tree node2, tree node3); tree ffecom_arg_expr (ffebld expr, tree *length); +tree ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length); tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length); -tree ffecom_call_gfrt (ffecomGfrt ix, tree args); +tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook); tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, ffeinfoKindtype kt, tree tree_type); +tree ffecom_const_expr (ffebld expr); tree ffecom_decl_field (tree context, tree prevfield, const char *name, tree type); #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ void ffecom_close_include (FILE *f); int ffecom_decode_include_option (char *spec); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree ffecom_end_compstmt (void); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ void ffecom_end_transition (void); void ffecom_exec_transition (void); void ffecom_expand_let_stmt (ffebld dest, ffebld source); @@ -295,7 +303,8 @@ void ffecom_expand_let_stmt (ffebld dest, ffebld source); tree ffecom_expr (ffebld expr); tree ffecom_expr_assign (ffebld expr); tree ffecom_expr_assign_w (ffebld expr); -tree ffecom_expr_rw (ffebld expr); +tree ffecom_expr_rw (tree type, ffebld expr); +tree ffecom_expr_w (tree type, ffebld expr); void ffecom_finish_compile (void); void ffecom_finish_decl (tree decl, tree init, bool is_top_level); void ffecom_finish_progunit (void); @@ -308,6 +317,8 @@ void ffecom_init_2 (void); tree ffecom_list_expr (ffebld list); tree ffecom_list_ptr_to_expr (ffebld list); tree ffecom_lookup_label (ffelab label); +tree ffecom_make_tempvar (const char *commentary, tree type, + ffetargetCharacterSize size, int elements); tree ffecom_modify (tree newtype, tree lhs, tree rhs); #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ void ffecom_file (char *name); @@ -316,14 +327,18 @@ void ffecom_notify_init_symbol (ffesymbol s); void ffecom_notify_primary_entry (ffesymbol fn); FILE *ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c); #if FFECOM_targetCURRENT == FFECOM_targetGCC -void ffecom_pop_calltemps (void); -void ffecom_pop_tempvar (tree var); +void ffecom_prepare_arg_ptr_to_expr (ffebld expr); +bool ffecom_prepare_end (void); +void ffecom_prepare_expr_ (ffebld expr, ffebld dest); +void ffecom_prepare_expr_rw (tree type, ffebld expr); +void ffecom_prepare_expr_w (tree type, ffebld expr); +void ffecom_prepare_ptr_to_expr (ffebld expr); +void ffecom_prepare_return_expr (ffebld expr); +tree ffecom_ptr_to_const_expr (ffebld expr); tree ffecom_ptr_to_expr (ffebld expr); -void ffecom_push_calltemps (void); -tree ffecom_push_tempvar (tree type, ffetargetCharacterSize size, - int elements, bool auto_pop); tree ffecom_return_expr (ffebld expr); tree ffecom_save_tree (tree t); +void ffecom_start_compstmt (void); tree ffecom_start_decl (tree decl, bool is_init); void ffecom_sym_commit (ffesymbol s); #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ @@ -335,6 +350,7 @@ void ffecom_sym_retract (ffesymbol s); tree ffecom_temp_label (void); tree ffecom_truth_value (tree expr); tree ffecom_truth_value_invert (tree expr); +tree ffecom_type_expr (ffebld expr); tree ffecom_which_entrypoint_decl (void); /* These need to be in the front end with exactly these interfaces, @@ -360,6 +376,7 @@ int mark_addressable (tree expr); #define ffecom_f2c_typecode(bt,kt) ffecom_f2c_typecode_[(bt)][(kt)] #define ffecom_label_kind() ffecom_label_kind_ #define ffecom_pointer_kind() ffecom_pointer_kind_ +#define ffecom_prepare_expr(e) ffecom_prepare_expr_ ((e), NULL) #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ #define ffecom_init_1() diff --git a/gcc/f/stc.c b/gcc/f/stc.c index 1a74301..b89b747 100644 --- a/gcc/f/stc.c +++ b/gcc/f/stc.c @@ -10000,6 +10000,10 @@ ffestc_R838 (ffelexToken label_token, ffebld target, return; ffestc_labeldef_branch_begin_ (); + /* Mark target symbol as target of an ASSIGN. */ + if (ffebld_op (target) == FFEBLD_opSYMTER) + ffesymbol_set_assigned (ffebld_symter (target), TRUE); + if (ffestc_labelref_is_assignable_ (label_token, &label)) ffestd_R838 (label, target); diff --git a/gcc/f/std.c b/gcc/f/std.c index 965c465..72037c1 100644 --- a/gcc/f/std.c +++ b/gcc/f/std.c @@ -192,17 +192,29 @@ struct _ffestd_stmt_ struct { mallocPool pool; + ffestw block; ffebld expr; } R803; struct { mallocPool pool; + ffestw block; ffebld expr; } R804; struct { + ffestw block; + } + R805; + struct + { + ffestw block; + } + R806; + struct + { mallocPool pool; ffebld expr; } @@ -750,27 +762,28 @@ ffestd_stmt_pass_ () case FFESTD_stmtidR803_: ffestd_subr_line_restore_ (stmt); if (okay) - ffeste_R803 (stmt->u.R803.expr); + ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr); malloc_pool_kill (stmt->u.R803.pool); break; case FFESTD_stmtidR804_: ffestd_subr_line_restore_ (stmt); if (okay) - ffeste_R804 (stmt->u.R804.expr); + ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr); malloc_pool_kill (stmt->u.R804.pool); break; case FFESTD_stmtidR805_: ffestd_subr_line_restore_ (stmt); if (okay) - ffeste_R805 (); + ffeste_R805 (stmt->u.R803.block); break; case FFESTD_stmtidR806_: ffestd_subr_line_restore_ (stmt); if (okay) - ffeste_R806 (); + ffeste_R806 (stmt->u.R806.block); + ffestw_kill (stmt->u.R806.block); break; case FFESTD_stmtidR807_: @@ -1597,7 +1610,19 @@ ffestd_labeldef_format (ffelab label) ffestdStmt_ stmt; stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_); +#if 0 + /* Don't bother with this. See FORMAT statement. */ + /* Prepend FORMAT label instead of appending it, so all the + FORMAT label/statement pairs end up at the top of the list. + This helps ensure all decls for a block (in the GBE) are + known before any executable statements are generated. */ + stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first; + stmt->next = ffestd_stmt_list_.first; + stmt->next->previous = stmt; + stmt->previous->next = stmt; +#else ffestd_stmt_append_ (stmt); +#endif stmt->u.formatlabel.label = label; } #endif @@ -2989,13 +3014,7 @@ ffestd_R744 () #endif } -/* ffestd_R745 -- Implicit END WHERE statement - - ffestd_R745(TRUE); - - Implement the end of the current WHERE "block". ok==TRUE iff statement - following WHERE (substatement) is valid; else, statement is invalid - or stack forcibly popped due to ffestd_eof_(). */ +/* ffestd_R745 -- Implicit END WHERE statement. */ void ffestd_R745 (bool ok) @@ -3011,11 +3030,8 @@ ffestd_R745 (bool ok) } #endif -/* ffestd_R803 -- Block IF (IF-THEN) statement - - ffestd_R803(construct_name,expr,expr_token); - Make sure statement is valid here; implement. */ +/* Block IF (IF-THEN) statement. */ void ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) @@ -3033,6 +3049,7 @@ ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); stmt->u.R803.pool = ffesta_output_pool; + stmt->u.R803.block = ffestw_use (ffestw_stack_top ()); stmt->u.R803.expr = expr; ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } @@ -3042,13 +3059,7 @@ ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr) assert (ffestd_block_level_ > 0); } -/* ffestd_R804 -- ELSE IF statement - - ffestd_R804(expr,expr_token,name_token); - - Make sure ffestd_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 ffestd_R804 (ffebld expr, ffelexToken name UNUSED) @@ -3066,19 +3077,14 @@ ffestd_R804 (ffebld expr, ffelexToken name UNUSED) ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); stmt->u.R804.pool = ffesta_output_pool; + stmt->u.R804.block = ffestw_use (ffestw_stack_top ()); stmt->u.R804.expr = expr; ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); } #endif } -/* ffestd_R805 -- ELSE statement - - ffestd_R805(name_token); - - Make sure ffestd_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 ffestd_R805 (ffelexToken name UNUSED) @@ -3095,13 +3101,12 @@ ffestd_R805 (ffelexToken name UNUSED) stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); + stmt->u.R805.block = ffestw_use (ffestw_stack_top ()); } #endif } -/* ffestd_R806 -- End an IF-THEN - - ffestd_R806(TRUE); */ +/* END IF statement. */ void ffestd_R806 (bool ok UNUSED) @@ -3116,6 +3121,7 @@ ffestd_R806 (bool ok UNUSED) stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_); ffestd_stmt_append_ (stmt); ffestd_subr_line_save_ (stmt); + stmt->u.R806.block = ffestw_use (ffestw_stack_top ()); } #endif @@ -4273,7 +4279,24 @@ ffestd_R1001 (ffesttFormatList f) ffestdStmt_ stmt; stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_); +#if 0 + /* Don't bother with this. After all, things like cilists also are + declared midway through code-generation. Perhaps the only problems + the gcc back end has with midway declarations are with stack vars, + maybe only with vars that can be put in registers. Unless/until the + need is established, handle FORMAT just like cilists and others; at + that point, they'd likely *all* have to be fixed, which would be + very painful anyway. */ + /* Insert FORMAT statement just after the first item on the + statement list, which must be a FORMAT label, which see. */ + assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_); + stmt->previous = ffestd_stmt_list_.first; + stmt->next = ffestd_stmt_list_.first->next; + stmt->next->previous = stmt; + stmt->previous->next = stmt; +#else ffestd_stmt_append_ (stmt); +#endif stmt->u.R1001.str = str; } #endif diff --git a/gcc/f/ste.c b/gcc/f/ste.c index e8c066e..b87f532 100644 --- a/gcc/f/ste.c +++ b/gcc/f/ste.c @@ -28,21 +28,6 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 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" @@ -114,8 +99,10 @@ static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr, 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); @@ -131,7 +118,23 @@ static tree ffeste_io_cllist_ (bool have_err, ffebld unit_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, @@ -177,118 +180,325 @@ static void ffeste_subr_file_ (const char *kw, ffestpFile *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); \ + } while(0) + +#define ffeste_f2c_prepare_charnolen_(Spec,Exp) \ do \ { \ - TREE_CHAIN(initn) = build_tree_list((field = TREE_CHAIN(field)),Init); \ - initn = TREE_CHAIN(initn); \ + if (! (Exp)) \ + ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ } 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_char_(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_format_(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_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)) \ { \ - Init = null_pointer_node; \ - constantp = FALSE; \ + 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)) \ + { \ + exq = ffecom_ptr_to_expr ((Spec)->u.expr); \ + ffeste_f2c_compile_ ((Field), exq); \ } \ } while(0) +/* 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. @@ -311,20 +521,40 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, tree tincr; tree tincr_saved; tree niters; + struct nesting *expanded_loop; + + /* Want to have tvar, tincr, and niters for the whole loop body. */ + + if (block) + ffeste_start_block_ (block); + else + ffeste_start_stmt_ (); + + niters = ffecom_make_tempvar (block ? "do" : "impdo", + ffecom_integer_type_node, + FFETARGET_charactersizeNONE, -1); - push_momentary (); /* Want to save these throughout the loop. */ + ffecom_prepare_expr (incr); + ffecom_prepare_expr_rw (NULL_TREE, var); - tvar = ffecom_expr_rw (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; } @@ -342,7 +572,16 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, 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); @@ -350,20 +589,26 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, 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, @@ -425,7 +670,7 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, tend, tstart); - if (!ffe_is_onetrip ()) + if (! ffe_is_onetrip ()) { expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr), expr, @@ -457,21 +702,22 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, 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_ (); - if (!ffe_is_onetrip ()) + expanded_loop = expand_start_loop_continue_elsewhere (!! block); + if (block) + ffestw_set_do_hook (block, expanded_loop); + + if (! ffe_is_onetrip ()) { expr = ffecom_truth_value (ffecom_2 (GE_EXPR, integer_type_node, @@ -486,21 +732,18 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, 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 @@ -510,7 +753,7 @@ ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, #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; @@ -520,6 +763,8 @@ ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar) expand_loop_continue_here (); + ffeste_start_stmt_ (); + if (ffe_is_onetrip ()) { expr = ffecom_truth_value @@ -540,27 +785,21 @@ ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar) 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 @@ -570,15 +809,13 @@ ffeste_io_call_ (tree call, bool do_check) 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. */ @@ -587,13 +824,96 @@ ffeste_io_call_ (tree call, bool do_check) 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 @@ -629,16 +949,11 @@ ffeste_io_dofio_ (ffebld expr) 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)" */ @@ -655,14 +970,15 @@ ffeste_io_dofio_ (ffebld expr) 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 @@ -681,17 +997,11 @@ ffeste_io_dofio_ (ffebld expr) 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 @@ -720,8 +1030,6 @@ ffeste_io_dolio_ (ffebld expr) || (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); @@ -736,10 +1044,7 @@ ffeste_io_dolio_ (ffebld expr) 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)" */ @@ -756,13 +1061,14 @@ ffeste_io_dolio_ (ffebld expr) 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 @@ -783,17 +1089,11 @@ ffeste_io_dolio_ (ffebld expr) 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 @@ -829,16 +1129,11 @@ ffeste_io_douio_ (ffebld expr) 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)" */ @@ -855,14 +1150,15 @@ ffeste_io_douio_ (ffebld expr) 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))); @@ -880,21 +1176,24 @@ ffeste_io_douio_ (ffebld expr) 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 @@ -938,23 +1237,23 @@ ffeste_io_ialist_ (bool have_err, 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; @@ -964,14 +1263,14 @@ ffeste_io_ialist_ (bool have_err, 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; @@ -989,7 +1288,20 @@ ffeste_io_ialist_ (bool have_err, 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); @@ -1000,15 +1312,20 @@ ffeste_io_ialist_ (bool have_err, } #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 @@ -1063,23 +1380,23 @@ ffeste_io_cilist_ (bool have_err, 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; @@ -1089,8 +1406,8 @@ ffeste_io_cilist_ (bool have_err, default: assert ("bad unit spec" == NULL); - unitexp = NULL_TREE; unitinit = ffecom_integer_zero_node; + unitexp = unitinit; break; } @@ -1098,11 +1415,11 @@ ffeste_io_cilist_ (bool have_err, { 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)) @@ -1114,12 +1431,9 @@ ffeste_io_cilist_ (bool have_err, 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; @@ -1129,7 +1443,7 @@ ffeste_io_cilist_ (bool have_err, case FFESTV_formatASTERISK: formatinit = null_pointer_node; - formatexp = NULL_TREE; + formatexp = formatinit; break; case FFESTV_formatINTEXPR: @@ -1143,27 +1457,24 @@ ffeste_io_cilist_ (bool have_err, 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; @@ -1172,10 +1483,10 @@ ffeste_io_cilist_ (bool have_err, 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; @@ -1193,9 +1504,40 @@ ffeste_io_cilist_ (bool have_err, 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); @@ -1206,15 +1548,20 @@ ffeste_io_cilist_ (bool have_err, } #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 @@ -1260,26 +1607,26 @@ ffeste_io_cllist_ (bool have_err, 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. */ - 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_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; @@ -1297,8 +1644,25 @@ ffeste_io_cllist_ (bool have_err, 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); @@ -1309,15 +1673,20 @@ ffeste_io_cllist_ (bool have_err, } #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 @@ -1371,48 +1740,54 @@ ffeste_io_icilist_ (bool have_err, 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)) + { + /* Not an array, so just one element. */ + unitnuminit = ffecom_integer_one_node; + unitnumexp = unitnuminit; + } + else if (unitexp && unitlenexp) { - unitnuminit = unitnumexp; - unitnumexp = NULL_TREE; + /* 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; } @@ -1420,11 +1795,11 @@ ffeste_io_icilist_ (bool have_err, { 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)) @@ -1436,22 +1811,12 @@ ffeste_io_icilist_ (bool have_err, 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: @@ -1465,21 +1830,21 @@ ffeste_io_icilist_ (bool have_err, 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; @@ -1497,106 +1862,71 @@ ffeste_io_icilist_ (bool have_err, resume_momentary (yes); - ffeste_f2c_exp_ (unitfield, unitexp); - ffeste_f2c_exp_ (formatfield, formatexp); - ffeste_f2c_exp_ (unitlenfield, unitlenexp); - ffeste_f2c_exp_ (unitnumfield, unitnumexp); + /* Prepare run-time expressions. */ - 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_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 @@ -1717,58 +2047,64 @@ ffeste_io_inlist_ (bool have_err, 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; @@ -1786,31 +2122,56 @@ ffeste_io_inlist_ (bool have_err, 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); @@ -1821,15 +2182,20 @@ ffeste_io_inlist_ (bool have_err, } #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 @@ -1896,37 +2262,38 @@ ffeste_io_olist_ (bool have_err, 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; @@ -1944,14 +2311,35 @@ ffeste_io_olist_ (bool have_err, 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); @@ -1962,9 +2350,7 @@ ffeste_io_olist_ (bool have_err, } #endif -/* ffeste_subr_file_ -- Display file-statement specifier - - ffeste_subr_file_(&specifier); */ +/* Display file-statement specifier. */ #if FFECOM_targetCURRENT == FFECOM_targetFFE static void @@ -1989,9 +2375,7 @@ ffeste_subr_file_ (const char *kw, ffestpFile *spec) } #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 @@ -2001,15 +2385,15 @@ ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) 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 @@ -2018,15 +2402,14 @@ ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) 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 @@ -2034,7 +2417,9 @@ ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) ffeste_io_abort_is_temp_ = FALSE; } else - { /* no ERR= */ + { + /* No ERR= specification. */ + ffeste_io_err_ = NULL_TREE; if ((ffeste_io_abort_is_temp_ = iostat)) @@ -2044,29 +2429,40 @@ ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) } 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. */ @@ -2079,28 +2475,16 @@ ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) 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) @@ -2109,28 +2493,26 @@ 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 - - ffeste_end_R807(TRUE); +/* End of statement following logical IF. - 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 () @@ -2139,16 +2521,16 @@ 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) @@ -2163,11 +2545,15 @@ 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 @@ -2175,9 +2561,7 @@ ffeste_labeldef_branch (ffelab label) #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) @@ -2191,9 +2575,7 @@ 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) @@ -2208,25 +2590,21 @@ 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_ (); @@ -2235,28 +2613,53 @@ ffeste_R803 (ffebld expr) ffebld_dump (expr); fputs (")\n", dmpout); #elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffeste_emit_line_note_ (); - ffecom_push_calltemps (); + { + tree temp; - expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); + ffeste_emit_line_note_ (); - ffecom_pop_calltemps (); - clear_momentary (); + ffeste_start_block_ (block); + + 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_ (); @@ -2265,28 +2668,65 @@ ffeste_R804 (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_ (); - 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_ (); @@ -2294,36 +2734,39 @@ ffeste_R805 () 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) @@ -2335,23 +2778,47 @@ ffeste_R807 (ffebld expr) ffebld_dump (expr); fputs (")\n", dmpout); #elif FFECOM_targetCURRENT == FFECOM_targetGCC - ffeste_emit_line_note_ (); - ffecom_push_calltemps (); + { + tree temp; - expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); + ffeste_emit_line_note_ (); - ffecom_pop_calltemps (); - clear_momentary (); + 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_ (); + + temp = ffecom_truth_value (ffecom_expr (expr)); + } + + 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) @@ -2363,52 +2830,63 @@ 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))); + + texpr = ffecom_modify (void_type_node, + result, + texpr); + expand_expr_stmt (texpr); + + ffeste_end_stmt_ (); - ffecom_pop_calltemps (); + 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 @@ -2466,17 +2944,18 @@ ffeste_R810 (ffestw block, unsigned long casenum) { 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 (); @@ -2516,15 +2995,13 @@ ffeste_R810 (ffestw block, unsigned long casenum) 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) @@ -2534,15 +3011,12 @@ 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 */ + + if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK) + expand_end_case (ffestw_select_texpr (block)); - expand_end_case (ffestw_select_texpr (block)); - pop_momentary (); - clear_momentary (); /* ~~~handle character and character*1 */ + ffeste_end_block_ (block); #else #error #endif @@ -2585,9 +3059,6 @@ ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var, #elif FFECOM_targetCURRENT == FFECOM_targetGCC { ffeste_emit_line_note_ (); - ffecom_push_calltemps (); - - /* Start the DO loop. */ ffeste_begin_iterdo_ (block, NULL, NULL, NULL, var, @@ -2595,19 +3066,13 @@ ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld 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) @@ -2623,32 +3088,50 @@ 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 () @@ -2659,17 +3142,14 @@ 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) @@ -2680,18 +3160,14 @@ 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) @@ -2702,19 +3178,14 @@ 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) @@ -2728,13 +3199,13 @@ 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 @@ -2742,12 +3213,7 @@ ffeste_R836 (ffelab label) #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) @@ -2776,12 +3242,17 @@ 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); @@ -2789,33 +3260,25 @@ ffeste_R837 (ffelab *labels, int count, ffebld expr) 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) @@ -2833,7 +3296,9 @@ 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) @@ -2843,31 +3308,28 @@ ffeste_R838 (ffelab label, ffebld target) 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) @@ -2883,15 +3345,17 @@ 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 @@ -2899,11 +3363,7 @@ ffeste_R839 (ffebld target) #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) @@ -2922,6 +3382,8 @@ 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) @@ -2929,15 +3391,19 @@ ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) || (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, @@ -2951,8 +3417,8 @@ ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) } } 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, @@ -2965,8 +3431,8 @@ ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) 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, @@ -2979,10 +3445,11 @@ ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) 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, @@ -3001,19 +3468,15 @@ ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) 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 () @@ -3024,15 +3487,14 @@ 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) @@ -3056,6 +3518,7 @@ ffeste_R842 (ffebld expr) ffelexToken msg; ffeste_emit_line_note_ (); + if ((expr == NULL) || (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeANY)) @@ -3099,12 +3562,16 @@ ffeste_R842 (ffebld expr) == 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 @@ -3112,12 +3579,7 @@ ffeste_R842 (ffebld expr) #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) @@ -3141,6 +3603,7 @@ ffeste_R843 (ffebld expr) ffelexToken msg; ffeste_emit_line_note_ (); + if ((expr == NULL) || (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeANY)) @@ -3184,12 +3647,16 @@ ffeste_R843 (ffebld expr) == 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 @@ -3198,28 +3665,25 @@ ffeste_R843 (ffebld expr) 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 @@ -3228,11 +3692,7 @@ ffeste_R843 (ffebld expr) #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) @@ -3277,23 +3737,16 @@ 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) { @@ -3314,31 +3767,48 @@ ffeste_R904 (ffestpOpenStmt *info) } 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_) { @@ -3349,27 +3819,14 @@ ffeste_R904 (ffestpOpenStmt *info) 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) @@ -3389,18 +3846,16 @@ 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) { @@ -3421,29 +3876,41 @@ ffeste_R907 (ffestpCloseStmt *info) } 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. */ @@ -3456,28 +3923,14 @@ ffeste_R907 (ffestpCloseStmt *info) 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, @@ -3553,12 +4006,8 @@ 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; @@ -3568,10 +4017,9 @@ ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, 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) { @@ -3624,45 +4072,34 @@ ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, } 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 (); @@ -3671,20 +4108,24 @@ ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, } } 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 (); @@ -3694,46 +4135,59 @@ ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, } 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) @@ -3746,27 +4200,35 @@ 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 () @@ -3780,73 +4242,56 @@ 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 (iostat<0) goto end_label; */ + 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 ((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 we've got a temp label, generate its code here and have it fan out + to the END= or ERR= label as appropriate. */ - /* 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, @@ -3900,12 +4345,8 @@ 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; @@ -3914,10 +4355,9 @@ ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, 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) { @@ -3962,32 +4402,21 @@ ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, } 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 @@ -3995,7 +4424,9 @@ ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, ffeste_io_abort_is_temp_ = FALSE; } else - { /* no ERR= */ + { + /* No ERR= specification. */ + ffeste_io_err_ = NULL_TREE; if ((ffeste_io_abort_is_temp_ = iostat)) @@ -4005,46 +4436,59 @@ ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, } 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) @@ -4057,23 +4501,30 @@ 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 () @@ -4087,45 +4538,29 @@ 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 (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 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 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) @@ -4158,18 +4593,15 @@ 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) { @@ -4198,10 +4630,7 @@ ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat 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; @@ -4210,26 +4639,25 @@ ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format) 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) @@ -4242,23 +4670,30 @@ 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 () @@ -4268,27 +4703,19 @@ 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) @@ -4308,11 +4735,7 @@ 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) @@ -4332,11 +4755,7 @@ 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) @@ -4356,11 +4775,7 @@ 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) @@ -4413,32 +4828,16 @@ 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) { @@ -4459,31 +4858,58 @@ ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED) } 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_) { @@ -4494,28 +4920,14 @@ ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED) 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) @@ -4528,18 +4940,14 @@ 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) @@ -4550,17 +4958,12 @@ 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 () @@ -4570,7 +4973,6 @@ ffeste_R923B_finish () #if FFECOM_targetCURRENT == FFECOM_targetFFE fputc ('\n', dmpout); #elif FFECOM_targetCURRENT == FFECOM_targetGCC - clear_momentary (); #else #error #endif @@ -4642,9 +5044,7 @@ ffeste_R1001 (ffests s) #endif } -/* ffeste_R1103 -- End a PROGRAM - - ffeste_R1103(); */ +/* END PROGRAM. */ void ffeste_R1103 () @@ -4657,9 +5057,7 @@ ffeste_R1103 () #endif } -/* ffeste_R1112 -- End a BLOCK DATA - - ffeste_R1112(TRUE); */ +/* END BLOCK DATA. */ void ffeste_R1112 () @@ -4672,11 +5070,7 @@ 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) @@ -4741,6 +5135,27 @@ 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 @@ -4751,43 +5166,41 @@ ffeste_R1212 (ffebld expr) 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 () @@ -4800,9 +5213,7 @@ ffeste_R1221 () #endif } -/* ffeste_R1225 -- End a SUBROUTINE - - ffeste_R1225(TRUE); */ +/* END SUBROUTINE. */ void ffeste_R1225 () @@ -4815,12 +5226,7 @@ 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) @@ -4868,23 +5274,19 @@ 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) @@ -4907,7 +5309,12 @@ 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); @@ -4928,20 +5335,14 @@ ffeste_R1227 (ffestw block UNUSED, ffebld 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 @@ -4976,11 +5377,7 @@ ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format) #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) @@ -4996,11 +5393,7 @@ 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 () @@ -5015,12 +5408,7 @@ 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) @@ -5055,11 +5443,7 @@ 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) @@ -5075,11 +5459,7 @@ 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 () @@ -5095,12 +5475,7 @@ 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, @@ -5136,11 +5511,7 @@ 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) @@ -5156,11 +5527,7 @@ 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 () @@ -5175,11 +5542,7 @@ 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 @@ -5200,11 +5563,7 @@ ffeste_V021 (ffestpDeleteStmt *info) #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) @@ -5223,12 +5582,7 @@ 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) @@ -5249,11 +5603,7 @@ 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) @@ -5269,11 +5619,7 @@ 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 () @@ -5288,12 +5634,7 @@ 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) @@ -5314,11 +5655,7 @@ 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) @@ -5334,11 +5671,7 @@ 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 () @@ -5353,12 +5686,7 @@ 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 () @@ -5373,11 +5701,7 @@ 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) @@ -5399,11 +5723,7 @@ 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 () @@ -5418,11 +5738,7 @@ 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) @@ -5443,3 +5759,11 @@ ffeste_V026 (ffestpFindStmt *info) } #endif + +#ifdef ENABLE_CHECKING +void +ffeste_terminate_2 (void) +{ + assert (! ffeste_top_block_); +} +#endif diff --git a/gcc/f/ste.h b/gcc/f/ste.h index 2c818759..78e9881 100644 --- a/gcc/f/ste.h +++ b/gcc/f/ste.h @@ -62,10 +62,10 @@ void ffeste_end_R807 (void); void ffeste_labeldef_branch (ffelab label); void ffeste_labeldef_format (ffelab label); void ffeste_R737A (ffebld dest, ffebld source); -void ffeste_R803 (ffebld expr); -void ffeste_R804 (ffebld expr); -void ffeste_R805 (void); -void ffeste_R806 (void); +void ffeste_R803 (ffestw block, ffebld expr); +void ffeste_R804 (ffestw block, ffebld expr); +void ffeste_R805 (ffestw block); +void ffeste_R806 (ffestw block); void ffeste_R807 (ffebld expr); void ffeste_R809 (ffestw block, ffebld expr); void ffeste_R810 (ffestw block, unsigned long casenum); @@ -159,7 +159,11 @@ void ffeste_V026 (ffestpFindStmt *info); #endif /* FFECOM_targetCURRENT == FFECOM_targetFFE */ #define ffeste_terminate_0() #define ffeste_terminate_1() +#ifdef ENABLE_CHECKING +void ffeste_terminate_2 (void); +#else #define ffeste_terminate_2() +#endif #define ffeste_terminate_3() #define ffeste_terminate_4() diff --git a/gcc/f/stw.h b/gcc/f/stw.h index 7a81d9b..58818a6 100644 --- a/gcc/f/stw.h +++ b/gcc/f/stw.h @@ -81,6 +81,7 @@ struct _ffestw_ tree select_texpr_; /* tree for end case. */ bool select_break_; /* TRUE when CASE should start with gen "break;". */ + int ifthen_fake_else_; /* Number of fake `else' introductions. */ #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC*/ }; @@ -137,6 +138,7 @@ ffestw ffestw_use (ffestw block); #define ffestw_do_iter_var(b) ((b)->do_iter_var_) #define ffestw_do_iter_var_t(b) ((b)->do_iter_var_t_) #define ffestw_do_tvar(b) ((b)->do_tvar_) +#define ffestw_ifthen_fake_else(b) ((b)->ifthen_fake_else_) #define ffestw_init_1() #define ffestw_init_2() #define ffestw_init_3() @@ -156,6 +158,7 @@ ffestw ffestw_use (ffestw block); #define ffestw_set_do_iter_var(b,v) ((b)->do_iter_var_ = (v)) #define ffestw_set_do_iter_var_t(b,t) ((b)->do_iter_var_t_ = (t)) #define ffestw_set_do_tvar(b,d) ((b)->do_tvar_ = (d)) +#define ffestw_set_ifthen_fake_else(b,e) ((b)->ifthen_fake_else_ = (e)) #define ffestw_set_label(b,l) ((b)->label_ = (l)) #define ffestw_set_line(b,l) ((b)->line_ = (l)) #define ffestw_set_name(b,n) ((b)->name_ = (n)) diff --git a/gcc/f/symbol.c b/gcc/f/symbol.c index 98b27fe..c4bd14d 100644 --- a/gcc/f/symbol.c +++ b/gcc/f/symbol.c @@ -255,6 +255,7 @@ ffesymbol_new_ (ffename n) s->reported = FALSE; s->explicit_where = FALSE; s->namelisted = FALSE; + s->assigned = FALSE; ffename_set_symbol (n, s); diff --git a/gcc/f/symbol.h b/gcc/f/symbol.h index 6082669..0c7262c 100644 --- a/gcc/f/symbol.h +++ b/gcc/f/symbol.h @@ -151,11 +151,13 @@ struct _ffesymbol_ away. */ bool explicit_where; /* TRUE if INTRINSIC/EXTERNAL explicit. */ bool namelisted; /* TRUE if in NAMELIST (needs static alloc). */ + bool assigned; /* TRUE if ever ASSIGNed to. */ }; #define ffesymbol_accretes(s) ((s)->accretes) #define ffesymbol_accretion(s) ((s)->accretion) #define ffesymbol_arraysize(s) ((s)->array_size) +#define ffesymbol_assigned(s) ((s)->assigned) #define ffesymbol_attr(s,a) ((s)->attrs & ((ffesymbolAttrs) 1 << (a))) #define ffesymbol_attrs(s) ((s)->attrs) const char *ffesymbol_attrs_string (ffesymbolAttrs attrs); @@ -231,6 +233,7 @@ bool ffesymbol_retractable (void); #define ffesymbol_set_accretes(s,a) ((s)->accretes = (a)) #define ffesymbol_set_accretion(s,a) ((s)->accretion = (a)) #define ffesymbol_set_arraysize(s,a) ((s)->array_size = (a)) +#define ffesymbol_set_assigned(s,a) ((s)->assigned = (a)) #define ffesymbol_set_attr(s,a) ((s)->attrs |= ((ffesymbolAttrs) 1 << (a))) #define ffesymbol_set_attrs(s,a) ((s)->attrs = (a)) #define ffesymbol_set_common(s,c) ((s)->common = (c)) diff --git a/gcc/f/version.c b/gcc/f/version.c index de648d5..807dbce 100644 --- a/gcc/f/version.c +++ b/gcc/f/version.c @@ -1 +1 @@ -const char *ffe_version_string = "0.5.24-19990405"; +const char *ffe_version_string = "0.5.24-19990417"; |