From c7e4ee3a6dfe2e2e57eecdb752693a417382eade Mon Sep 17 00:00:00 2001 From: Craig Burley Date: Sat, 17 Apr 1999 10:58:35 +0000 Subject: [PATCH] rewrite to use block/scope structure of GBE From-SVN: r26515 --- gcc/f/ChangeLog | 109 + gcc/f/bld.c | 9 + gcc/f/bld.h | 19 +- gcc/f/com.c | 19336 ++++++++++++++++++++++++---------------------- gcc/f/com.h | 31 +- gcc/f/stc.c | 4 + gcc/f/std.c | 87 +- gcc/f/ste.c | 2994 +++---- gcc/f/ste.h | 12 +- gcc/f/stw.h | 3 + gcc/f/symbol.c | 1 + gcc/f/symbol.h | 3 + gcc/f/version.c | 2 +- 13 files changed, 11859 insertions(+), 10751 deletions(-) diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog index 9d2f1342d6c2..8d07c01ca5d2 100644 --- a/gcc/f/ChangeLog +++ b/gcc/f/ChangeLog @@ -1,3 +1,112 @@ +Sat Apr 17 13:53:43 1999 Craig Burley + + 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 * g77spec.c (lang_specific_driver): Check whether MATH_LIBRARY is diff --git a/gcc/f/bld.c b/gcc/f/bld.c index 6ef559e077a8..15cadf196d1b 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 96c8e5e05ef9..ddbd44841e7b 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 dabf049be4d4..1d7676dbba22 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,2920 +5245,2686 @@ 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); + NULL_TREE, TRUE, + ffebld_nonter_hook (expr)); - /**INDENT* (Do not reformat this comment even with -fca option.) - Data-gathering files: Given the source file listed below, compiled with - f2c I obtained the output file listed after that, and from the output - file I derived the above code. + /* See bottom of this file for f2c transforms used to determine + many of the above implementations. The info seems to confuse + Emacs's C mode indentation, which is why it's been moved to + the bottom of this source file. */ +} --------- (begin input file to f2c) - implicit none - character*10 A1,A2 - complex C1,C2 - integer I1,I2 - real R1,R2 - double precision D1,D2 -C - call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) -c / - call fooI(I1/I2) - call fooR(R1/I1) - call fooD(D1/I1) - call fooC(C1/I1) - call fooR(R1/R2) - call fooD(R1/D1) - call fooD(D1/D2) - call fooD(D1/R1) - call fooC(C1/C2) - call fooC(C1/R1) - call fooZ(C1/D1) -c ** - call fooI(I1**I2) - call fooR(R1**I1) - call fooD(D1**I1) - call fooC(C1**I1) - call fooR(R1**R2) - call fooD(R1**D1) - call fooD(D1**D2) - call fooD(D1**R1) - call fooC(C1**C2) - call fooC(C1**R1) - call fooZ(C1**D1) -c FFEINTRIN_impABS - call fooR(ABS(R1)) -c FFEINTRIN_impACOS - call fooR(ACOS(R1)) -c FFEINTRIN_impAIMAG - call fooR(AIMAG(C1)) -c FFEINTRIN_impAINT - call fooR(AINT(R1)) -c FFEINTRIN_impALOG - call fooR(ALOG(R1)) -c FFEINTRIN_impALOG10 - call fooR(ALOG10(R1)) -c FFEINTRIN_impAMAX0 - call fooR(AMAX0(I1,I2)) -c FFEINTRIN_impAMAX1 - call fooR(AMAX1(R1,R2)) -c FFEINTRIN_impAMIN0 - call fooR(AMIN0(I1,I2)) -c FFEINTRIN_impAMIN1 - call fooR(AMIN1(R1,R2)) -c FFEINTRIN_impAMOD - call fooR(AMOD(R1,R2)) -c FFEINTRIN_impANINT - call fooR(ANINT(R1)) -c FFEINTRIN_impASIN - call fooR(ASIN(R1)) -c FFEINTRIN_impATAN - call fooR(ATAN(R1)) -c FFEINTRIN_impATAN2 - call fooR(ATAN2(R1,R2)) -c FFEINTRIN_impCABS - call fooR(CABS(C1)) -c FFEINTRIN_impCCOS - call fooC(CCOS(C1)) -c FFEINTRIN_impCEXP - call fooC(CEXP(C1)) -c FFEINTRIN_impCHAR - call fooA(CHAR(I1)) -c FFEINTRIN_impCLOG - call fooC(CLOG(C1)) -c FFEINTRIN_impCONJG - call fooC(CONJG(C1)) -c FFEINTRIN_impCOS - call fooR(COS(R1)) -c FFEINTRIN_impCOSH - call fooR(COSH(R1)) -c FFEINTRIN_impCSIN - call fooC(CSIN(C1)) -c FFEINTRIN_impCSQRT - call fooC(CSQRT(C1)) -c FFEINTRIN_impDABS - call fooD(DABS(D1)) -c FFEINTRIN_impDACOS - call fooD(DACOS(D1)) -c FFEINTRIN_impDASIN - call fooD(DASIN(D1)) -c FFEINTRIN_impDATAN - call fooD(DATAN(D1)) -c FFEINTRIN_impDATAN2 - call fooD(DATAN2(D1,D2)) -c FFEINTRIN_impDCOS - call fooD(DCOS(D1)) -c FFEINTRIN_impDCOSH - call fooD(DCOSH(D1)) -c FFEINTRIN_impDDIM - call fooD(DDIM(D1,D2)) -c FFEINTRIN_impDEXP - call fooD(DEXP(D1)) -c FFEINTRIN_impDIM - call fooR(DIM(R1,R2)) -c FFEINTRIN_impDINT - call fooD(DINT(D1)) -c FFEINTRIN_impDLOG - call fooD(DLOG(D1)) -c FFEINTRIN_impDLOG10 - call fooD(DLOG10(D1)) -c FFEINTRIN_impDMAX1 - call fooD(DMAX1(D1,D2)) -c FFEINTRIN_impDMIN1 - call fooD(DMIN1(D1,D2)) -c FFEINTRIN_impDMOD - call fooD(DMOD(D1,D2)) -c FFEINTRIN_impDNINT - call fooD(DNINT(D1)) -c FFEINTRIN_impDPROD - call fooD(DPROD(R1,R2)) -c FFEINTRIN_impDSIGN - call fooD(DSIGN(D1,D2)) -c FFEINTRIN_impDSIN - call fooD(DSIN(D1)) -c FFEINTRIN_impDSINH - call fooD(DSINH(D1)) -c FFEINTRIN_impDSQRT - call fooD(DSQRT(D1)) -c FFEINTRIN_impDTAN - call fooD(DTAN(D1)) -c FFEINTRIN_impDTANH - call fooD(DTANH(D1)) -c FFEINTRIN_impEXP - call fooR(EXP(R1)) -c FFEINTRIN_impIABS - call fooI(IABS(I1)) -c FFEINTRIN_impICHAR - call fooI(ICHAR(A1)) -c FFEINTRIN_impIDIM - call fooI(IDIM(I1,I2)) -c FFEINTRIN_impIDNINT - call fooI(IDNINT(D1)) -c FFEINTRIN_impINDEX - call fooI(INDEX(A1,A2)) -c FFEINTRIN_impISIGN - call fooI(ISIGN(I1,I2)) -c FFEINTRIN_impLEN - call fooI(LEN(A1)) -c FFEINTRIN_impLGE - call fooL(LGE(A1,A2)) -c FFEINTRIN_impLGT - call fooL(LGT(A1,A2)) -c FFEINTRIN_impLLE - call fooL(LLE(A1,A2)) -c FFEINTRIN_impLLT - call fooL(LLT(A1,A2)) -c FFEINTRIN_impMAX0 - call fooI(MAX0(I1,I2)) -c FFEINTRIN_impMAX1 - call fooI(MAX1(R1,R2)) -c FFEINTRIN_impMIN0 - call fooI(MIN0(I1,I2)) -c FFEINTRIN_impMIN1 - call fooI(MIN1(R1,R2)) -c FFEINTRIN_impMOD - call fooI(MOD(I1,I2)) -c FFEINTRIN_impNINT - call fooI(NINT(R1)) -c FFEINTRIN_impSIGN - call fooR(SIGN(R1,R2)) -c FFEINTRIN_impSIN - call fooR(SIN(R1)) -c FFEINTRIN_impSINH - call fooR(SINH(R1)) -c FFEINTRIN_impSQRT - call fooR(SQRT(R1)) -c FFEINTRIN_impTAN - call fooR(TAN(R1)) -c FFEINTRIN_impTANH - call fooR(TANH(R1)) -c FFEINTRIN_imp_CMPLX_C - call fooC(cmplx(C1,C2)) -c FFEINTRIN_imp_CMPLX_D - call fooZ(cmplx(D1,D2)) -c FFEINTRIN_imp_CMPLX_I - call fooC(cmplx(I1,I2)) -c FFEINTRIN_imp_CMPLX_R - call fooC(cmplx(R1,R2)) -c FFEINTRIN_imp_DBLE_C - call fooD(dble(C1)) -c FFEINTRIN_imp_DBLE_D - call fooD(dble(D1)) -c FFEINTRIN_imp_DBLE_I - call fooD(dble(I1)) -c FFEINTRIN_imp_DBLE_R - call fooD(dble(R1)) -c FFEINTRIN_imp_INT_C - call fooI(int(C1)) -c FFEINTRIN_imp_INT_D - call fooI(int(D1)) -c FFEINTRIN_imp_INT_I - call fooI(int(I1)) -c FFEINTRIN_imp_INT_R - call fooI(int(R1)) -c FFEINTRIN_imp_REAL_C - call fooR(real(C1)) -c FFEINTRIN_imp_REAL_D - call fooR(real(D1)) -c FFEINTRIN_imp_REAL_I - call fooR(real(I1)) -c FFEINTRIN_imp_REAL_R - call fooR(real(R1)) -c -c FFEINTRIN_imp_INT_D: -c -c FFEINTRIN_specIDINT - call fooI(IDINT(D1)) -c -c FFEINTRIN_imp_INT_R: -c -c FFEINTRIN_specIFIX - call fooI(IFIX(R1)) -c FFEINTRIN_specINT - call fooI(INT(R1)) -c -c FFEINTRIN_imp_REAL_D: -c -c FFEINTRIN_specSNGL - call fooR(SNGL(D1)) -c -c FFEINTRIN_imp_REAL_I: -c -c FFEINTRIN_specFLOAT - call fooR(FLOAT(I1)) -c FFEINTRIN_specREAL - call fooR(REAL(I1)) -c - end --------- (end input file to f2c) - --------- (begin output from providing above input file as input to: --------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ --------- -e "s:^#.*$::g"') - -// -- translated by f2c (version 19950223). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -// - - -// f2c.h -- Standard Fortran to C header file // +#endif +/* For power (exponentiation) where right-hand operand is type INTEGER, + generate in-line code to do it the fast way (which, if the operand + is a constant, might just mean a series of multiplies). */ -/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_expr_power_integer_ (ffebld expr) +{ + tree l = ffecom_expr (ffebld_left (expr)); + tree r = ffecom_expr (ffebld_right (expr)); + tree ltype = TREE_TYPE (l); + tree rtype = TREE_TYPE (r); + tree result = NULL_TREE; - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // + if (l == error_mark_node + || r == error_mark_node) + return error_mark_node; + if (TREE_CODE (r) == INTEGER_CST) + { + int sgn = tree_int_cst_sgn (r); + if (sgn == 0) + return convert (ltype, integer_one_node); + if ((TREE_CODE (ltype) == INTEGER_TYPE) + && (sgn < 0)) + { + /* Reciprocal of integer is either 0, -1, or 1, so after + calculating that (which we leave to the back end to do + or not do optimally), don't bother with any multiplying. */ -// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // -// we assume short, float are OK // -typedef long int // long int // integer; -typedef char *address; -typedef short int shortint; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -typedef long int // long int // logical; -typedef short int shortlogical; -typedef char logical1; -typedef char integer1; -// typedef long long longint; // // system-dependent // + result = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL, NULL_TREE); + r = ffecom_1 (NEGATE_EXPR, + rtype, + r); + if ((TREE_INT_CST_LOW (r) & 1) == 0) + result = ffecom_1 (ABS_EXPR, rtype, + result); + } + /* Generate appropriate series of multiplies, preceded + by divide if the exponent is negative. */ + l = save_expr (l); + if (sgn < 0) + { + l = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL, + ffebld_nonter_hook (expr)); + r = ffecom_1 (NEGATE_EXPR, rtype, r); + assert (TREE_CODE (r) == INTEGER_CST); -// Extern is for use with -E // + if (tree_int_cst_sgn (r) < 0) + { /* The "most negative" number. */ + r = ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node)); + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + } + for (;;) + { + if (TREE_INT_CST_LOW (r) & 1) + { + if (result == NULL_TREE) + result = l; + else + result = ffecom_2 (MULT_EXPR, ltype, + result, + l); + } + r = ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node); + if (integer_zerop (r)) + break; + assert (TREE_CODE (r) == INTEGER_CST); + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + return result; + } -// I/O stuff // + /* Though rhs isn't a constant, in-line code cannot be expanded + while transforming dummies + because the back end cannot be easily convinced to generate + stores (MODIFY_EXPR), handle temporaries, and so on before + all the appropriate rtx's have been generated for things like + dummy args referenced in rhs -- which doesn't happen until + store_parm_decls() is called (expand_function_start, I believe, + does the actual rtx-stuffing of PARM_DECLs). + So, in this case, let the caller generate the call to the + run-time-library function to evaluate the power for us. */ + if (ffecom_transform_only_dummies_) + return NULL_TREE; + /* Right-hand operand not a constant, expand in-line code to figure + out how to do the multiplies, &c. + The returned expression is expressed this way in GNU C, where l and + r are the "inputs": + ({ typeof (r) rtmp = r; + typeof (l) ltmp = l; + typeof (l) result; + if (rtmp == 0) + result = 1; + else + { + if ((basetypeof (l) == basetypeof (int)) + && (rtmp < 0)) + { + result = ((typeof (l)) 1) / ltmp; + if ((ltmp < 0) && (((-rtmp) & 1) == 0)) + result = -result; + } + else + { + result = 1; + if ((basetypeof (l) != basetypeof (int)) + && (rtmp < 0)) + { + ltmp = ((typeof (l)) 1) / ltmp; + rtmp = -rtmp; + if (rtmp < 0) + { + rtmp = -(rtmp >> 1); + ltmp *= ltmp; + } + } + for (;;) + { + if (rtmp & 1) + result *= ltmp; + if ((rtmp >>= 1) == 0) + break; + ltmp *= ltmp; + } + } + } + result; + }) + Note that some of the above is compile-time collapsable, such as + the first part of the if statements that checks the base type of + l against int. The if statements are phrased that way to suggest + an easy way to generate the if/else constructs here, knowing that + the back end should (and probably does) eliminate the resulting + dead code (either the int case or the non-int case), something + it couldn't do without the redundant phrasing, requiring explicit + dead-code elimination here, which would be kind of difficult to + read. */ -typedef long int // int or long int // flag; -typedef long int // int or long int // ftnlen; -typedef long int // int or long int // ftnint; + { + tree rtmp; + tree ltmp; + tree divide; + tree basetypeof_l_is_int; + tree se; + tree t; + basetypeof_l_is_int + = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); -//external read, write// -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; + se = expand_start_stmt_expr (); -//internal read, write// -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; + ffecom_start_compstmt (); + +#ifndef HAHA + rtmp = ffecom_make_tempvar ("power_r", rtype, + FFETARGET_charactersizeNONE, -1); + ltmp = ffecom_make_tempvar ("power_l", ltype, + FFETARGET_charactersizeNONE, -1); + result = ffecom_make_tempvar ("power_res", ltype, + FFETARGET_charactersizeNONE, -1); + if (TREE_CODE (ltype) == COMPLEX_TYPE + || TREE_CODE (ltype) == RECORD_TYPE) + divide = ffecom_make_tempvar ("power_div", ltype, + FFETARGET_charactersizeNONE, -1); + else + divide = NULL_TREE; +#else /* HAHA */ + { + tree hook; + + hook = ffebld_nonter_hook (expr); + assert (hook); + assert (TREE_CODE (hook) == TREE_VEC); + assert (TREE_VEC_LENGTH (hook) == 4); + rtmp = TREE_VEC_ELT (hook, 0); + ltmp = TREE_VEC_ELT (hook, 1); + result = TREE_VEC_ELT (hook, 2); + divide = TREE_VEC_ELT (hook, 3); + if (TREE_CODE (ltype) == COMPLEX_TYPE + || TREE_CODE (ltype) == RECORD_TYPE) + assert (divide); + else + assert (! divide); + } +#endif /* HAHA */ -//open// -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + r)); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + l)); + expand_start_cond (ffecom_truth_value + (ffecom_2 (EQ_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_else (); + if (! integer_zerop (basetypeof_l_is_int)) + { + expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL, + divide))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_2 (LT_EXPR, integer_type_node, + ltmp, + convert (ltype, + integer_zero_node)), + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_2 (BIT_AND_EXPR, + rtype, + ffecom_1 (NEGATE_EXPR, + rtype, + rtmp), + convert (rtype, + integer_one_node)), + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_1 (NEGATE_EXPR, + ltype, + result))); + expand_end_cond (); + expand_start_else (); + } + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_truth_value_invert + (basetypeof_l_is_int), + ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL, + divide))); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + rtmp))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_cond (); + expand_end_cond (); + expand_start_loop (1); + expand_start_cond (ffecom_truth_value + (ffecom_2 (BIT_AND_EXPR, rtype, + rtmp, + convert (rtype, integer_one_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_2 (MULT_EXPR, ltype, + result, + ltmp))); + expand_end_cond (); + expand_exit_loop_if_false (NULL, + ffecom_truth_value + (ffecom_modify (rtype, + rtmp, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_loop (); + expand_end_cond (); + if (!integer_zerop (basetypeof_l_is_int)) + expand_end_cond (); + expand_expr_stmt (result); -//close// -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; + t = ffecom_end_compstmt (); -//rewind, backspace, endfile// -typedef struct -{ flag aerr; - ftnint aunit; -} alist; + result = expand_end_stmt_expr (se); -// inquire // -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; //parameters in standard's order// - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; + /* This code comes from c-parse.in, after its expand_end_stmt_expr. */ + if (TREE_CODE (t) == BLOCK) + { + /* Make a BIND_EXPR for the BLOCK already made. */ + result = build (BIND_EXPR, TREE_TYPE (result), + NULL_TREE, result, t); + /* Remove the block from the tree at this point. + It gets put back at the proper place + when the BIND_EXPR is expanded. */ + delete_block (t); + } + else + result = t; + } + return result; +} -union Multitype { // for multiple entry points // - integer1 g; - shortint h; - integer i; - // longint j; // - real r; - doublereal d; - complex c; - doublecomplex z; - }; +#endif +/* ffecom_expr_transform_ -- Transform symbols in expr -typedef union Multitype Multitype; + ffebld expr; // FFE expression. + ffecom_expr_transform_ (expr); -typedef long Long; // No longer used; formerly in Namelist // + Recursive descent on expr while transforming any untransformed SYMTERs. */ -struct Vardesc { // for Namelist // - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_expr_transform_ (ffebld expr) +{ + tree t; + ffesymbol s; -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; +tail_recurse: /* :::::::::::::::::::: */ + if (expr == NULL) + return; + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + t = ffesymbol_hook (s).decl_tree; + if ((t == NULL_TREE) + && ((ffesymbol_kind (s) != FFEINFO_kindNONE) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy, + DIMENSION expr? */ + } + break; /* Ok if (t == NULL) here. */ + case FFEBLD_opITEM: + ffecom_expr_transform_ (ffebld_head (expr)); + expr = ffebld_trail (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + default: + break; + } + switch (ffebld_arity (expr)) + { + case 2: + ffecom_expr_transform_ (ffebld_left (expr)); + expr = ffebld_right (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + case 1: + expr = ffebld_left (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + default: + break; + } -// procedure parameter types for -A and -C++ // + return; +} +#endif +/* Make a type based on info in live f2c.h file. */ +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_f2c_make_type_ (tree *type, int tcode, const char *name) +{ + switch (tcode) + { + case FFECOM_f2ccodeCHAR: + *type = make_signed_type (CHAR_TYPE_SIZE); + break; + case FFECOM_f2ccodeSHORT: + *type = make_signed_type (SHORT_TYPE_SIZE); + break; -typedef int // Unknown procedure type // (*U_fp)(); -typedef shortint (*J_fp)(); -typedef integer (*I_fp)(); -typedef real (*R_fp)(); -typedef doublereal (*D_fp)(), (*E_fp)(); -typedef // Complex // void (*C_fp)(); -typedef // Double Complex // void (*Z_fp)(); -typedef logical (*L_fp)(); -typedef shortlogical (*K_fp)(); -typedef // Character // void (*H_fp)(); -typedef // Subroutine // int (*S_fp)(); + case FFECOM_f2ccodeINT: + *type = make_signed_type (INT_TYPE_SIZE); + break; -// E_fp is for real functions when -R is not specified // -typedef void C_f; // complex function // -typedef void H_f; // character function // -typedef void Z_f; // double complex function // -typedef doublereal E_f; // real function with -R not specified // + case FFECOM_f2ccodeLONG: + *type = make_signed_type (LONG_TYPE_SIZE); + break; -// undef any lower-case symbols that your C compiler predefines, e.g.: // + case FFECOM_f2ccodeLONGLONG: + *type = make_signed_type (LONG_LONG_TYPE_SIZE); + break; + case FFECOM_f2ccodeCHARPTR: + *type = build_pointer_type (DEFAULT_SIGNED_CHAR + ? signed_char_type_node + : unsigned_char_type_node); + break; -// (No such symbols should be defined in a strict ANSI C compiler. - We can avoid trouble with f2c-translated code by using - gcc -ansi [-traditional].) // + case FFECOM_f2ccodeFLOAT: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeLONGDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + case FFECOM_f2ccodeTWOREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node); + break; + case FFECOM_f2ccodeTWODOUBLEREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node); + break; + default: + assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL); + *type = error_mark_node; + return; + } + pushdecl (build_decl (TYPE_DECL, + ffecom_get_invented_identifier ("__g77_f2c_%s", + name, -1), + *type)); +} +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +/* Set the f2c list-directed-I/O code for whatever (integral) type has the + given size. */ +static void +ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, + int code) +{ + int j; + tree t; + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + if (((t = ffecom_tree_type[bt][j]) != NULL_TREE) + && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size)) + { + assert (code != -1); + ffecom_f2c_typecode_[bt][j] = code; + code = -1; + } +} +#endif +/* Finish up globals after doing all program units in file + Need to handle only uninitialized COMMON areas. */ +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffeglobal +ffecom_finish_global_ (ffeglobal global) +{ + tree cbtype; + tree cbt; + tree size; + if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON) + return global; + if (ffeglobal_common_init (global)) + return global; + cbt = ffeglobal_hook (global); + if ((cbt == NULL_TREE) + || !ffeglobal_common_have_size (global)) + return global; /* No need to make common, never ref'd. */ + suspend_momentary (); + DECL_EXTERNAL (cbt) = 0; + /* Give the array a size now. */ + size = build_int_2 ((ffeglobal_common_size (global) + + ffeglobal_common_pad (global)) - 1, + 0); + cbtype = TREE_TYPE (cbt); + TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, + integer_zero_node, + size); + if (!TREE_TYPE (size)) + TREE_TYPE (size) = TYPE_DOMAIN (cbtype); + layout_type (cbtype); + cbt = start_decl (cbt, FALSE); + assert (cbt == ffeglobal_hook (global)); + finish_decl (cbt, NULL_TREE, FALSE); + return global; +} +#endif +/* Finish up any untransformed symbols. */ -// Main program // MAIN__() +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_finish_symbol_transform_ (ffesymbol s) { - // System generated locals // - integer i__1; - real r__1, r__2; - doublereal d__1, d__2; - complex q__1; - doublecomplex z__1, z__2, z__3; - logical L__1; - char ch__1[1]; + if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK)) + return s; - // Builtin functions // - void c_div(); - integer pow_ii(); - double pow_ri(), pow_di(); - void pow_ci(); - double pow_dd(); - void pow_zz(); - double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), - asin(), atan(), atan2(), c_abs(); - void c_cos(), c_exp(), c_log(), r_cnjg(); - double cos(), cosh(); - void c_sin(), c_sqrt(); - double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), - d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); - integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); - logical l_ge(), l_gt(), l_le(), l_lt(); - integer i_nint(); - double r_sign(); + /* It's easy to know to transform an untransformed symbol, to make sure + we put out debugging info for it. But COMMON variables, unlike + EQUIVALENCE ones, aren't given declarations in addition to the + tree expressions that specify offsets, because COMMON variables + can be referenced in the outer scope where only dummy arguments + (PARM_DECLs) should really be seen. To be safe, just don't do any + VAR_DECLs for COMMON variables when we transform them for real + use, and therefore we do all the VAR_DECL creating here. */ - // Local variables // - extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), - fool_(), fooz_(), getem_(); - static char a1[10], a2[10]; - static complex c1, c2; - static doublereal d1, d2; - static integer i1, i2; - static real r1, r2; + if (ffesymbol_hook (s).decl_tree == NULL_TREE) + { + if (ffesymbol_kind (s) != FFEINFO_kindNONE + || (ffesymbol_where (s) != FFEINFO_whereNONE + && ffesymbol_where (s) != FFEINFO_whereINTRINSIC + && ffesymbol_where (s) != FFEINFO_whereDUMMY)) + /* Not transformed, and not CHARACTER*(*), and not a dummy + argument, which can happen only if the entry point names + it "rides in on" are all invalidated for other reasons. */ + s = ffecom_sym_transform_ (s); + } + if ((ffesymbol_where (s) == FFEINFO_whereCOMMON) + && (ffesymbol_hook (s).decl_tree != error_mark_node)) + { +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + int yes = suspend_momentary (); - getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); -// / // - i__1 = i1 / i2; - fooi_(&i__1); - r__1 = r1 / i1; - foor_(&r__1); - d__1 = d1 / i1; - food_(&d__1); - d__1 = (doublereal) i1; - q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; - fooc_(&q__1); - r__1 = r1 / r2; - foor_(&r__1); - d__1 = r1 / d1; - food_(&d__1); - d__1 = d1 / d2; - food_(&d__1); - d__1 = d1 / r1; - food_(&d__1); - c_div(&q__1, &c1, &c2); - fooc_(&q__1); - q__1.r = c1.r / r1, q__1.i = c1.i / r1; - fooc_(&q__1); - z__1.r = c1.r / d1, z__1.i = c1.i / d1; - fooz_(&z__1); -// ** // - i__1 = pow_ii(&i1, &i2); - fooi_(&i__1); - r__1 = pow_ri(&r1, &i1); - foor_(&r__1); - d__1 = pow_di(&d1, &i1); - food_(&d__1); - pow_ci(&q__1, &c1, &i1); - fooc_(&q__1); - d__1 = (doublereal) r1; - d__2 = (doublereal) r2; - r__1 = pow_dd(&d__1, &d__2); - foor_(&r__1); - d__2 = (doublereal) r1; - d__1 = pow_dd(&d__2, &d1); - food_(&d__1); - d__1 = pow_dd(&d1, &d2); - food_(&d__1); - d__2 = (doublereal) r1; - d__1 = pow_dd(&d1, &d__2); - food_(&d__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = c2.r, z__3.i = c2.i; - pow_zz(&z__1, &z__2, &z__3); - q__1.r = z__1.r, q__1.i = z__1.i; - fooc_(&q__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = r1, z__3.i = 0.; - pow_zz(&z__1, &z__2, &z__3); - q__1.r = z__1.r, q__1.i = z__1.i; - fooc_(&q__1); - z__2.r = c1.r, z__2.i = c1.i; - z__3.r = d1, z__3.i = 0.; - pow_zz(&z__1, &z__2, &z__3); - fooz_(&z__1); -// FFEINTRIN_impABS // - r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; - foor_(&r__1); -// FFEINTRIN_impACOS // - r__1 = acos(r1); - foor_(&r__1); -// FFEINTRIN_impAIMAG // - r__1 = r_imag(&c1); - foor_(&r__1); -// FFEINTRIN_impAINT // - r__1 = r_int(&r1); - foor_(&r__1); -// FFEINTRIN_impALOG // - r__1 = log(r1); - foor_(&r__1); -// FFEINTRIN_impALOG10 // - r__1 = r_lg10(&r1); - foor_(&r__1); -// FFEINTRIN_impAMAX0 // - r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMAX1 // - r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMIN0 // - r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMIN1 // - r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; - foor_(&r__1); -// FFEINTRIN_impAMOD // - r__1 = r_mod(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impANINT // - r__1 = r_nint(&r1); - foor_(&r__1); -// FFEINTRIN_impASIN // - r__1 = asin(r1); - foor_(&r__1); -// FFEINTRIN_impATAN // - r__1 = atan(r1); - foor_(&r__1); -// FFEINTRIN_impATAN2 // - r__1 = atan2(r1, r2); - foor_(&r__1); -// FFEINTRIN_impCABS // - r__1 = c_abs(&c1); - foor_(&r__1); -// FFEINTRIN_impCCOS // - c_cos(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCEXP // - c_exp(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCHAR // - *(unsigned char *)&ch__1[0] = i1; - fooa_(ch__1, 1L); -// FFEINTRIN_impCLOG // - c_log(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCONJG // - r_cnjg(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCOS // - r__1 = cos(r1); - foor_(&r__1); -// FFEINTRIN_impCOSH // - r__1 = cosh(r1); - foor_(&r__1); -// FFEINTRIN_impCSIN // - c_sin(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impCSQRT // - c_sqrt(&q__1, &c1); - fooc_(&q__1); -// FFEINTRIN_impDABS // - d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; - food_(&d__1); -// FFEINTRIN_impDACOS // - d__1 = acos(d1); - food_(&d__1); -// FFEINTRIN_impDASIN // - d__1 = asin(d1); - food_(&d__1); -// FFEINTRIN_impDATAN // - d__1 = atan(d1); - food_(&d__1); -// FFEINTRIN_impDATAN2 // - d__1 = atan2(d1, d2); - food_(&d__1); -// FFEINTRIN_impDCOS // - d__1 = cos(d1); - food_(&d__1); -// FFEINTRIN_impDCOSH // - d__1 = cosh(d1); - food_(&d__1); -// FFEINTRIN_impDDIM // - d__1 = d_dim(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDEXP // - d__1 = exp(d1); - food_(&d__1); -// FFEINTRIN_impDIM // - r__1 = r_dim(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impDINT // - d__1 = d_int(&d1); - food_(&d__1); -// FFEINTRIN_impDLOG // - d__1 = log(d1); - food_(&d__1); -// FFEINTRIN_impDLOG10 // - d__1 = d_lg10(&d1); - food_(&d__1); -// FFEINTRIN_impDMAX1 // - d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; - food_(&d__1); -// FFEINTRIN_impDMIN1 // - d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; - food_(&d__1); -// FFEINTRIN_impDMOD // - d__1 = d_mod(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDNINT // - d__1 = d_nint(&d1); - food_(&d__1); -// FFEINTRIN_impDPROD // - d__1 = (doublereal) r1 * r2; - food_(&d__1); -// FFEINTRIN_impDSIGN // - d__1 = d_sign(&d1, &d2); - food_(&d__1); -// FFEINTRIN_impDSIN // - d__1 = sin(d1); - food_(&d__1); -// FFEINTRIN_impDSINH // - d__1 = sinh(d1); - food_(&d__1); -// FFEINTRIN_impDSQRT // - d__1 = sqrt(d1); - food_(&d__1); -// FFEINTRIN_impDTAN // - d__1 = tan(d1); - food_(&d__1); -// FFEINTRIN_impDTANH // - d__1 = tanh(d1); - food_(&d__1); -// FFEINTRIN_impEXP // - r__1 = exp(r1); - foor_(&r__1); -// FFEINTRIN_impIABS // - i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; - fooi_(&i__1); -// FFEINTRIN_impICHAR // - i__1 = *(unsigned char *)a1; - fooi_(&i__1); -// FFEINTRIN_impIDIM // - i__1 = i_dim(&i1, &i2); - fooi_(&i__1); -// FFEINTRIN_impIDNINT // - i__1 = i_dnnt(&d1); - fooi_(&i__1); -// FFEINTRIN_impINDEX // - i__1 = i_indx(a1, a2, 10L, 10L); - fooi_(&i__1); -// FFEINTRIN_impISIGN // - i__1 = i_sign(&i1, &i2); - fooi_(&i__1); -// FFEINTRIN_impLEN // - i__1 = i_len(a1, 10L); - fooi_(&i__1); -// FFEINTRIN_impLGE // - L__1 = l_ge(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLGT // - L__1 = l_gt(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLLE // - L__1 = l_le(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impLLT // - L__1 = l_lt(a1, a2, 10L, 10L); - fool_(&L__1); -// FFEINTRIN_impMAX0 // - i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMAX1 // - i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMIN0 // - i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMIN1 // - i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; - fooi_(&i__1); -// FFEINTRIN_impMOD // - i__1 = i1 % i2; - fooi_(&i__1); -// FFEINTRIN_impNINT // - i__1 = i_nint(&r1); - fooi_(&i__1); -// FFEINTRIN_impSIGN // - r__1 = r_sign(&r1, &r2); - foor_(&r__1); -// FFEINTRIN_impSIN // - r__1 = sin(r1); - foor_(&r__1); -// FFEINTRIN_impSINH // - r__1 = sinh(r1); - foor_(&r__1); -// FFEINTRIN_impSQRT // - r__1 = sqrt(r1); - foor_(&r__1); -// FFEINTRIN_impTAN // - r__1 = tan(r1); - foor_(&r__1); -// FFEINTRIN_impTANH // - r__1 = tanh(r1); - foor_(&r__1); -// FFEINTRIN_imp_CMPLX_C // - r__1 = c1.r; - r__2 = c2.r; - q__1.r = r__1, q__1.i = r__2; - fooc_(&q__1); -// FFEINTRIN_imp_CMPLX_D // - z__1.r = d1, z__1.i = d2; - fooz_(&z__1); -// FFEINTRIN_imp_CMPLX_I // - r__1 = (real) i1; - r__2 = (real) i2; - q__1.r = r__1, q__1.i = r__2; - fooc_(&q__1); -// FFEINTRIN_imp_CMPLX_R // - q__1.r = r1, q__1.i = r2; - fooc_(&q__1); -// FFEINTRIN_imp_DBLE_C // - d__1 = (doublereal) c1.r; - food_(&d__1); -// FFEINTRIN_imp_DBLE_D // - d__1 = d1; - food_(&d__1); -// FFEINTRIN_imp_DBLE_I // - d__1 = (doublereal) i1; - food_(&d__1); -// FFEINTRIN_imp_DBLE_R // - d__1 = (doublereal) r1; - food_(&d__1); -// FFEINTRIN_imp_INT_C // - i__1 = (integer) c1.r; - fooi_(&i__1); -// FFEINTRIN_imp_INT_D // - i__1 = (integer) d1; - fooi_(&i__1); -// FFEINTRIN_imp_INT_I // - i__1 = i1; - fooi_(&i__1); -// FFEINTRIN_imp_INT_R // - i__1 = (integer) r1; - fooi_(&i__1); -// FFEINTRIN_imp_REAL_C // - r__1 = c1.r; - foor_(&r__1); -// FFEINTRIN_imp_REAL_D // - r__1 = (real) d1; - foor_(&r__1); -// FFEINTRIN_imp_REAL_I // - r__1 = (real) i1; - foor_(&r__1); -// FFEINTRIN_imp_REAL_R // - r__1 = r1; - foor_(&r__1); - -// FFEINTRIN_imp_INT_D: // - -// FFEINTRIN_specIDINT // - i__1 = (integer) d1; - fooi_(&i__1); - -// FFEINTRIN_imp_INT_R: // - -// FFEINTRIN_specIFIX // - i__1 = (integer) r1; - fooi_(&i__1); -// FFEINTRIN_specINT // - i__1 = (integer) r1; - fooi_(&i__1); - -// FFEINTRIN_imp_REAL_D: // - -// FFEINTRIN_specSNGL // - r__1 = (real) d1; - foor_(&r__1); - -// FFEINTRIN_imp_REAL_I: // - -// FFEINTRIN_specFLOAT // - r__1 = (real) i1; - foor_(&r__1); -// FFEINTRIN_specREAL // - r__1 = (real) i1; - foor_(&r__1); - -} // MAIN__ // - --------- (end output file from f2c) - -*/ -} - -#endif -/* For power (exponentiation) where right-hand operand is type INTEGER, - generate in-line code to do it the fast way (which, if the operand - is a constant, might just mean a series of multiplies). */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_expr_power_integer_ (ffebld left, ffebld right) -{ - tree l = ffecom_expr (left); - tree r = ffecom_expr (right); - tree ltype = TREE_TYPE (l); - tree rtype = TREE_TYPE (r); - tree result = NULL_TREE; - - if (l == error_mark_node - || r == error_mark_node) - return error_mark_node; - - if (TREE_CODE (r) == INTEGER_CST) - { - int sgn = tree_int_cst_sgn (r); - - if (sgn == 0) - return convert (ltype, integer_one_node); - - if ((TREE_CODE (ltype) == INTEGER_TYPE) - && (sgn < 0)) - { - /* Reciprocal of integer is either 0, -1, or 1, so after - calculating that (which we leave to the back end to do - or not do optimally), don't bother with any multiplying. */ - - result = ffecom_tree_divide_ (ltype, - convert (ltype, integer_one_node), - l, - NULL_TREE, NULL, NULL); - r = ffecom_1 (NEGATE_EXPR, - rtype, - r); - if ((TREE_INT_CST_LOW (r) & 1) == 0) - result = ffecom_1 (ABS_EXPR, rtype, - result); - } - - /* Generate appropriate series of multiplies, preceded - by divide if the exponent is negative. */ - - l = save_expr (l); - - if (sgn < 0) - { - l = ffecom_tree_divide_ (ltype, - convert (ltype, integer_one_node), - l, - NULL_TREE, NULL, NULL); - r = ffecom_1 (NEGATE_EXPR, rtype, r); - assert (TREE_CODE (r) == INTEGER_CST); - - if (tree_int_cst_sgn (r) < 0) - { /* The "most negative" number. */ - r = ffecom_1 (NEGATE_EXPR, rtype, - ffecom_2 (RSHIFT_EXPR, rtype, - r, - integer_one_node)); - l = save_expr (l); - l = ffecom_2 (MULT_EXPR, ltype, - l, - l); - } - } - - for (;;) - { - if (TREE_INT_CST_LOW (r) & 1) - { - if (result == NULL_TREE) - result = l; - else - result = ffecom_2 (MULT_EXPR, ltype, - result, - l); - } - - r = ffecom_2 (RSHIFT_EXPR, rtype, - r, - integer_one_node); - if (integer_zerop (r)) - break; - assert (TREE_CODE (r) == INTEGER_CST); + /* This isn't working, at least for dbxout. The .s file looks + okay to me (burley), but in gdb 4.9 at least, the variables + appear to reside somewhere outside of the common area, so + it doesn't make sense to mislead anyone by generating the info + on those variables until this is fixed. NOTE: Same problem + with EQUIVALENCE, sadly...see similar #if later. */ + ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)), + ffesymbol_storage (s)); - l = save_expr (l); - l = ffecom_2 (MULT_EXPR, ltype, - l, - l); - } - return result; + resume_momentary (yes); +#endif } - /* Though rhs isn't a constant, in-line code cannot be expanded - while transforming dummies - because the back end cannot be easily convinced to generate - stores (MODIFY_EXPR), handle temporaries, and so on before - all the appropriate rtx's have been generated for things like - dummy args referenced in rhs -- which doesn't happen until - store_parm_decls() is called (expand_function_start, I believe, - does the actual rtx-stuffing of PARM_DECLs). + return s; +} - So, in this case, let the caller generate the call to the - run-time-library function to evaluate the power for us. */ +#endif +/* Append underscore(s) to name before calling get_identifier. "us" + is nonzero if the name already contains an underscore and thus + needs two underscores appended. */ - if (ffecom_transform_only_dummies_) - return NULL_TREE; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_appended_identifier_ (char us, const char *name) +{ + int i; + char *newname; + tree id; - /* Right-hand operand not a constant, expand in-line code to figure - out how to do the multiplies, &c. + newname = xmalloc ((i = strlen (name)) + 1 + + ffe_is_underscoring () + + us); + memcpy (newname, name, i); + newname[i] = '_'; + newname[i + us] = '_'; + newname[i + 1 + us] = '\0'; + id = get_identifier (newname); - The returned expression is expressed this way in GNU C, where l and - r are the "inputs": + free (newname); - ({ typeof (r) rtmp = r; - typeof (l) ltmp = l; - typeof (l) result; + return id; +} - if (rtmp == 0) - result = 1; - else - { - if ((basetypeof (l) == basetypeof (int)) - && (rtmp < 0)) - { - result = ((typeof (l)) 1) / ltmp; - if ((ltmp < 0) && (((-rtmp) & 1) == 0)) - result = -result; - } - else - { - result = 1; - if ((basetypeof (l) != basetypeof (int)) - && (rtmp < 0)) - { - ltmp = ((typeof (l)) 1) / ltmp; - rtmp = -rtmp; - if (rtmp < 0) - { - rtmp = -(rtmp >> 1); - ltmp *= ltmp; - } - } - for (;;) - { - if (rtmp & 1) - result *= ltmp; - if ((rtmp >>= 1) == 0) - break; - ltmp *= ltmp; - } - } - } - result; - }) +#endif +/* Decide whether to append underscore to name before calling + get_identifier. */ - Note that some of the above is compile-time collapsable, such as - the first part of the if statements that checks the base type of - l against int. The if statements are phrased that way to suggest - an easy way to generate the if/else constructs here, knowing that - the back end should (and probably does) eliminate the resulting - dead code (either the int case or the non-int case), something - it couldn't do without the redundant phrasing, requiring explicit - dead-code elimination here, which would be kind of difficult to - read. */ +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_external_identifier_ (ffesymbol s) +{ + char us; + const char *name = ffesymbol_text (s); - { - tree rtmp; - tree ltmp; - tree basetypeof_l_is_int; - tree se; + /* If name is a built-in name, just return it as is. */ - basetypeof_l_is_int - = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); + if (!ffe_is_underscoring () + || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0) +#if FFETARGET_isENFORCED_MAIN_NAME + || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0) +#else + || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) +#endif + || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0)) + return get_identifier (name); - se = expand_start_stmt_expr (); - ffecom_push_calltemps (); + us = ffe_is_second_underscore () + ? (strchr (name, '_') != NULL) + : 0; - rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1, - TRUE); - ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, - TRUE); - result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, - TRUE); + return ffecom_get_appended_identifier_ (us, name); +} - expand_expr_stmt (ffecom_modify (void_type_node, - rtmp, - r)); - expand_expr_stmt (ffecom_modify (void_type_node, - ltmp, - l)); - expand_start_cond (ffecom_truth_value - (ffecom_2 (EQ_EXPR, integer_type_node, - rtmp, - convert (rtype, integer_zero_node))), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - result, - convert (ltype, integer_one_node))); - expand_start_else (); - if (!integer_zerop (basetypeof_l_is_int)) - { - expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, - rtmp, - convert (rtype, - integer_zero_node)), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - result, - ffecom_tree_divide_ - (ltype, - convert (ltype, integer_one_node), - ltmp, - NULL_TREE, NULL, NULL))); - expand_start_cond (ffecom_truth_value - (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, - ffecom_2 (LT_EXPR, integer_type_node, - ltmp, - convert (ltype, - integer_zero_node)), - ffecom_2 (EQ_EXPR, integer_type_node, - ffecom_2 (BIT_AND_EXPR, - rtype, - ffecom_1 (NEGATE_EXPR, - rtype, - rtmp), - convert (rtype, - integer_one_node)), - convert (rtype, - integer_zero_node)))), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - result, - ffecom_1 (NEGATE_EXPR, - ltype, - result))); - expand_end_cond (); - expand_start_else (); - } - expand_expr_stmt (ffecom_modify (void_type_node, - result, - convert (ltype, integer_one_node))); - expand_start_cond (ffecom_truth_value - (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, - ffecom_truth_value_invert - (basetypeof_l_is_int), - ffecom_2 (LT_EXPR, integer_type_node, - rtmp, - convert (rtype, - integer_zero_node)))), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - ltmp, - ffecom_tree_divide_ - (ltype, - convert (ltype, integer_one_node), - ltmp, - NULL_TREE, NULL, NULL))); - expand_expr_stmt (ffecom_modify (void_type_node, - rtmp, - ffecom_1 (NEGATE_EXPR, rtype, - rtmp))); - expand_start_cond (ffecom_truth_value - (ffecom_2 (LT_EXPR, integer_type_node, - rtmp, - convert (rtype, integer_zero_node))), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - rtmp, - ffecom_1 (NEGATE_EXPR, rtype, - ffecom_2 (RSHIFT_EXPR, - rtype, - rtmp, - integer_one_node)))); - expand_expr_stmt (ffecom_modify (void_type_node, - ltmp, - ffecom_2 (MULT_EXPR, ltype, - ltmp, - ltmp))); - expand_end_cond (); - expand_end_cond (); - expand_start_loop (1); - expand_start_cond (ffecom_truth_value - (ffecom_2 (BIT_AND_EXPR, rtype, - rtmp, - convert (rtype, integer_one_node))), - 0); - expand_expr_stmt (ffecom_modify (void_type_node, - result, - ffecom_2 (MULT_EXPR, ltype, - result, - ltmp))); - expand_end_cond (); - expand_exit_loop_if_false (NULL, - ffecom_truth_value - (ffecom_modify (rtype, - rtmp, - ffecom_2 (RSHIFT_EXPR, - rtype, - rtmp, - integer_one_node)))); - expand_expr_stmt (ffecom_modify (void_type_node, - ltmp, - ffecom_2 (MULT_EXPR, ltype, - ltmp, - ltmp))); - expand_end_loop (); - expand_end_cond (); - if (!integer_zerop (basetypeof_l_is_int)) - expand_end_cond (); - expand_expr_stmt (result); +#endif +/* Decide whether to append underscore to internal name before calling + get_identifier. + + This is for non-external, top-function-context names only. Transform + identifier so it doesn't conflict with the transformed result + of using a _different_ external name. E.g. if "CALL FOO" is + transformed into "FOO_();", then the variable in "FOO_ = 3" + must be transformed into something that does not conflict, since + these two things should be independent. - ffecom_pop_calltemps (); - result = expand_end_stmt_expr (se); - TREE_SIDE_EFFECTS (result) = 1; - } + The transformation is as follows. If the name does not contain + an underscore, there is no possible conflict, so just return. + If the name does contain an underscore, then transform it just + like we transform an external identifier. */ - return result; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_get_identifier_ (const char *name) +{ + /* If name does not contain an underscore, just return it as is. */ + + if (!ffe_is_underscoring () + || (strchr (name, '_') == NULL)) + return get_identifier (name); + + return ffecom_get_appended_identifier_ (ffe_is_second_underscore (), + name); } #endif -/* ffecom_expr_transform_ -- Transform symbols in expr +/* ffecom_gen_sfuncdef_ -- Generate definition of statement function - ffebld expr; // FFE expression. - ffecom_expr_transform_ (expr); + tree t; + ffesymbol s; // kindFUNCTION, whereIMMEDIATE. + t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s), + ffesymbol_kindtype(s)); - Recursive descent on expr while transforming any untransformed SYMTERs. */ + Call after setting up containing function and getting trees for all + other symbols. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_expr_transform_ (ffebld expr) +static tree +ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) { - tree t; - ffesymbol s; + ffebld expr = ffesymbol_sfexpr (s); + tree type; + tree func; + tree result; + bool charfunc = (bt == FFEINFO_basictypeCHARACTER); + static bool recurse = FALSE; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; -tail_recurse: /* :::::::::::::::::::: */ + ffecom_nested_entry_ = s; - if (expr == NULL) - return; + /* For now, we don't have a handy pointer to where the sfunc is actually + defined, though that should be easy to add to an ffesymbol. (The + token/where info available might well point to the place where the type + of the sfunc is declared, especially if that precedes the place where + the sfunc itself is defined, which is typically the case.) We should + put out a null pointer rather than point somewhere wrong, but I want to + see how it works at this point. */ - switch (ffebld_op (expr)) - { - case FFEBLD_opSYMTER: - s = ffebld_symter (expr); - t = ffesymbol_hook (s).decl_tree; - if ((t == NULL_TREE) - && ((ffesymbol_kind (s) != FFEINFO_kindNONE) - || ((ffesymbol_where (s) != FFEINFO_whereNONE) - && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))) - { - s = ffecom_sym_transform_ (s); - t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy, - DIMENSION expr? */ - } - break; /* Ok if (t == NULL) here. */ + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); - case FFEBLD_opITEM: - ffecom_expr_transform_ (ffebld_head (expr)); - expr = ffebld_trail (expr); - goto tail_recurse; /* :::::::::::::::::::: */ + /* Pretransform the expression so any newly discovered things belong to the + outer program unit, not to the statement function. */ - default: - break; - } + ffecom_expr_transform_ (expr); - switch (ffebld_arity (expr)) + /* Make sure no recursive invocation of this fn (a specific case of failing + to pretransform an sfunc's expression, i.e. where its expression + references another untransformed sfunc) happens. */ + + assert (!recurse); + recurse = TRUE; + + yes = suspend_momentary (); + + push_f_function_context (); + + if (charfunc) + type = void_type_node; + else { - case 2: - ffecom_expr_transform_ (ffebld_left (expr)); - expr = ffebld_right (expr); - goto tail_recurse; /* :::::::::::::::::::: */ + type = ffecom_tree_type[bt][kt]; + if (type == NULL_TREE) + type = integer_type_node; /* _sym_exec_transition reports + error. */ + } - case 1: - expr = ffebld_left (expr); - goto tail_recurse; /* :::::::::::::::::::: */ + start_function (ffecom_get_identifier_ (ffesymbol_text (s)), + build_function_type (type, NULL_TREE), + 1, /* nested/inline */ + 0); /* TREE_PUBLIC */ - default: - break; + /* We don't worry about COMPLEX return values here, because this is + entirely internal to our code, and gcc has the ability to return COMPLEX + directly as a value. */ + + yes = suspend_momentary (); + + if (charfunc) + { /* Prepend arg for where result goes. */ + tree type; + + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", -1); + + ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); } + else + result = NULL_TREE; /* Not ref'd if !charfunc. */ - return; -} + ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE); -#endif -/* Make a type based on info in live f2c.h file. */ + resume_momentary (yes); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_f2c_make_type_ (tree *type, int tcode, const char *name) -{ - switch (tcode) + store_parm_decls (0); + + ffecom_start_compstmt (); + + if (expr != NULL) { - case FFECOM_f2ccodeCHAR: - *type = make_signed_type (CHAR_TYPE_SIZE); - break; + if (charfunc) + { + ffetargetCharacterSize sz = ffesymbol_size (s); + tree result_length; - case FFECOM_f2ccodeSHORT: - *type = make_signed_type (SHORT_TYPE_SIZE); - break; + result_length = build_int_2 (sz, 0); + TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; - case FFECOM_f2ccodeINT: - *type = make_signed_type (INT_TYPE_SIZE); - break; + ffecom_prepare_let_char_ (sz, expr); - case FFECOM_f2ccodeLONG: - *type = make_signed_type (LONG_TYPE_SIZE); - break; + ffecom_prepare_end (); - case FFECOM_f2ccodeLONGLONG: - *type = make_signed_type (LONG_LONG_TYPE_SIZE); - break; + ffecom_let_char_ (result, result_length, sz, expr); + expand_null_return (); + } + else + { + ffecom_prepare_expr (expr); - case FFECOM_f2ccodeCHARPTR: - *type = build_pointer_type (DEFAULT_SIGNED_CHAR - ? signed_char_type_node - : unsigned_char_type_node); - break; + ffecom_prepare_end (); - case FFECOM_f2ccodeFLOAT: - *type = make_node (REAL_TYPE); - TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE; - layout_type (*type); - break; + expand_return (ffecom_modify (NULL_TREE, + DECL_RESULT (current_function_decl), + ffecom_expr (expr))); + } - case FFECOM_f2ccodeDOUBLE: - *type = make_node (REAL_TYPE); - TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE; - layout_type (*type); - break; + clear_momentary (); + } - case FFECOM_f2ccodeLONGDOUBLE: - *type = make_node (REAL_TYPE); - TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE; - layout_type (*type); - break; + ffecom_end_compstmt (); - case FFECOM_f2ccodeTWOREALS: - *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node); - break; + func = current_function_decl; + finish_function (1); - case FFECOM_f2ccodeTWODOUBLEREALS: - *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node); - break; + pop_f_function_context (); - default: - assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL); - *type = error_mark_node; - return; - } + resume_momentary (yes); - pushdecl (build_decl (TYPE_DECL, - ffecom_get_invented_identifier ("__g77_f2c_%s", - name, 0), - *type)); + recurse = FALSE; + + lineno = old_lineno; + input_filename = old_input_filename; + + ffecom_nested_entry_ = NULL; + + return func; } #endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -/* Set the f2c list-directed-I/O code for whatever (integral) type has the - given size. */ -static void -ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, - int code) +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static const char * +ffecom_gfrt_args_ (ffecomGfrt ix) { - int j; - tree t; + return ffecom_gfrt_argstring_[ix]; +} - for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) - if (((t = ffecom_tree_type[bt][j]) != NULL_TREE) - && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size)) - { - assert (code != -1); - ffecom_f2c_typecode_[bt][j] = code; - code = -1; - } +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_gfrt_tree_ (ffecomGfrt ix) +{ + if (ffecom_gfrt_[ix] == NULL_TREE) + ffecom_make_gfrt_ (ix); + + return ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])), + ffecom_gfrt_[ix]); } #endif -/* Finish up globals after doing all program units in file - - Need to handle only uninitialized COMMON areas. */ +/* Return initialize-to-zero expression for this VAR_DECL. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static ffeglobal -ffecom_finish_global_ (ffeglobal global) +static tree +ffecom_init_zero_ (tree decl) { - tree cbtype; - tree cbt; - tree size; - - if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON) - return global; - - if (ffeglobal_common_init (global)) - return global; + tree init; + int incremental = TREE_STATIC (decl); + tree type = TREE_TYPE (decl); - cbt = ffeglobal_hook (global); - if ((cbt == NULL_TREE) - || !ffeglobal_common_have_size (global)) - return global; /* No need to make common, never ref'd. */ + if (incremental) + { + int momentary = suspend_momentary (); + push_obstacks_nochange (); + if (TREE_PERMANENT (decl)) + end_temporary_allocation (); + make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0); + assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); + pop_obstacks (); + resume_momentary (momentary); + } - suspend_momentary (); + push_momentary (); - DECL_EXTERNAL (cbt) = 0; + if ((TREE_CODE (type) != ARRAY_TYPE) + && (TREE_CODE (type) != RECORD_TYPE) + && (TREE_CODE (type) != UNION_TYPE) + && !incremental) + init = convert (type, integer_zero_node); + else if (!incremental) + { + int momentary = suspend_momentary (); - /* Give the array a size now. */ + init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE); + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; - size = build_int_2 ((ffeglobal_common_size (global) - + ffeglobal_common_pad (global)) - 1, - 0); + resume_momentary (momentary); + } + else + { + int momentary = suspend_momentary (); - cbtype = TREE_TYPE (cbt); - TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, - integer_zero_node, - size); - if (!TREE_TYPE (size)) - TREE_TYPE (size) = TYPE_DOMAIN (cbtype); - layout_type (cbtype); + assemble_zeros (int_size_in_bytes (type)); + init = error_mark_node; - cbt = start_decl (cbt, FALSE); - assert (cbt == ffeglobal_hook (global)); + resume_momentary (momentary); + } - finish_decl (cbt, NULL_TREE, FALSE); + pop_momentary_nofree (); - return global; + return init; } #endif -/* Finish up any untransformed symbols. */ - #if FFECOM_targetCURRENT == FFECOM_targetGCC -static ffesymbol -ffecom_finish_symbol_transform_ (ffesymbol s) +static tree +ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, + tree *maybe_tree) { - if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK)) - return s; - - /* It's easy to know to transform an untransformed symbol, to make sure - we put out debugging info for it. But COMMON variables, unlike - EQUIVALENCE ones, aren't given declarations in addition to the - tree expressions that specify offsets, because COMMON variables - can be referenced in the outer scope where only dummy arguments - (PARM_DECLs) should really be seen. To be safe, just don't do any - VAR_DECLs for COMMON variables when we transform them for real - use, and therefore we do all the VAR_DECL creating here. */ + tree expr_tree; + tree length_tree; - if (ffesymbol_hook (s).decl_tree == NULL_TREE) + switch (ffebld_op (arg)) { - if (ffesymbol_kind (s) != FFEINFO_kindNONE - || (ffesymbol_where (s) != FFEINFO_whereNONE - && ffesymbol_where (s) != FFEINFO_whereINTRINSIC - && ffesymbol_where (s) != FFEINFO_whereDUMMY)) - /* Not transformed, and not CHARACTER*(*), and not a dummy - argument, which can happen only if the entry point names - it "rides in on" are all invalidated for other reasons. */ - s = ffecom_sym_transform_ (s); - } + case FFEBLD_opCONTER: /* For F90, check 0-length. */ + if (ffetarget_length_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } - if ((ffesymbol_where (s) == FFEINFO_whereCOMMON) - && (ffesymbol_hook (s).decl_tree != error_mark_node)) - { -#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING - int yes = suspend_momentary (); + *maybe_tree = integer_one_node; + expr_tree = build_int_2 (*ffetarget_text_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))), + 0); + TREE_TYPE (expr_tree) = tree_type; + return expr_tree; - /* This isn't working, at least for dbxout. The .s file looks - okay to me (burley), but in gdb 4.9 at least, the variables - appear to reside somewhere outside of the common area, so - it doesn't make sense to mislead anyone by generating the info - on those variables until this is fixed. NOTE: Same problem - with EQUIVALENCE, sadly...see similar #if later. */ - ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)), - ffesymbol_storage (s)); + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + ffecom_char_args_ (&expr_tree, &length_tree, arg); - resume_momentary (yes); -#endif - } + if ((expr_tree == error_mark_node) + || (length_tree == error_mark_node)) + { + *maybe_tree = error_mark_node; + return error_mark_node; + } - return s; + if (integer_zerop (length_tree)) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + + expr_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree); + expr_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree, + integer_one_node); + expr_tree = convert (tree_type, expr_tree); + + if (TREE_CODE (length_tree) == INTEGER_CST) + *maybe_tree = integer_one_node; + else /* Must check length at run time. */ + *maybe_tree + = ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + length_tree, + ffecom_f2c_ftnlen_zero_node)); + return expr_tree; + + case FFEBLD_opPAREN: + case FFEBLD_opCONVERT: + if (ffeinfo_size (ffebld_info (arg)) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + maybe_tree); + + case FFEBLD_opCONCATENATE: + { + tree maybe_left; + tree maybe_right; + tree expr_left; + tree expr_right; + + expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + &maybe_left); + expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg), + &maybe_right); + *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + maybe_left, + maybe_right); + expr_tree = ffecom_3 (COND_EXPR, tree_type, + maybe_left, + expr_left, + expr_right); + return expr_tree; + } + + default: + assert ("bad op in ICHAR" == NULL); + return error_mark_node; + } } #endif -/* Append underscore(s) to name before calling get_identifier. "us" - is nonzero if the name already contains an underscore and thus - needs two underscores appended. */ +/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN()) + + tree length_arg; + ffebld expr; + length_arg = ffecom_intrinsic_len_ (expr); + + Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF + subexpressions by constructing the appropriate tree for the + length-of-character-text argument in a calling sequence. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static tree -ffecom_get_appended_identifier_ (char us, const char *name) +ffecom_intrinsic_len_ (ffebld expr) { - int i; - char *newname; - tree id; + ffetargetCharacter1 val; + tree length; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + val = ffebld_constant_character1 (ffebld_conter (expr)); + length = build_int_2 (ffetarget_length_character1 (val), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; + + case FFEBLD_opSYMTER: + { + ffesymbol s = ffebld_symter (expr); + tree item; + + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (ffesymbol_kind (s) == FFEINFO_kindENTITY) + { + if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) + length = ffesymbol_hook (s).length_tree; + else + { + length = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + } + } + else if (item == error_mark_node) + length = error_mark_node; + else /* FFEINFO_kindFUNCTION: */ + length = NULL_TREE; + } + break; - newname = xmalloc ((i = strlen (name)) + 1 - + ffe_is_underscoring () - + us); - memcpy (newname, name, i); - newname[i] = '_'; - newname[i + us] = '_'; - newname[i + 1 + us] = '\0'; - id = get_identifier (newname); + case FFEBLD_opARRAYREF: + length = ffecom_intrinsic_len_ (ffebld_left (expr)); + break; - free (newname); + case FFEBLD_opSUBSTR: + { + ffebld start; + ffebld end; + ffebld thing = ffebld_right (expr); + tree start_tree; + tree end_tree; - return id; -} + assert (ffebld_op (thing) == FFEBLD_opITEM); + start = ffebld_head (thing); + thing = ffebld_trail (thing); + assert (ffebld_trail (thing) == NULL); + end = ffebld_head (thing); -#endif -/* Decide whether to append underscore to name before calling - get_identifier. */ + length = ffecom_intrinsic_len_ (ffebld_left (expr)); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_get_external_identifier_ (ffesymbol s) -{ - char us; - const char *name = ffesymbol_text (s); + if (length == error_mark_node) + break; - /* If name is a built-in name, just return it as is. */ + if (start == NULL) + { + if (end == NULL) + ; + else + { + length = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + } + } + else + { + start_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (start)); - if (!ffe_is_underscoring () - || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0) -#if FFETARGET_isENFORCED_MAIN_NAME - || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0) -#else - || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) -#endif - || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0)) - return get_identifier (name); + if (start_tree == error_mark_node) + { + length = error_mark_node; + break; + } - us = ffe_is_second_underscore () - ? (strchr (name, '_') != NULL) - : 0; + if (end == NULL) + { + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + length, + start_tree)); + } + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); - return ffecom_get_appended_identifier_ (us, name); -} + if (end_tree == error_mark_node) + { + length = error_mark_node; + break; + } -#endif -/* Decide whether to append underscore to internal name before calling - get_identifier. + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + end_tree, start_tree)); + } + } + } + break; - This is for non-external, top-function-context names only. Transform - identifier so it doesn't conflict with the transformed result - of using a _different_ external name. E.g. if "CALL FOO" is - transformed into "FOO_();", then the variable in "FOO_ = 3" - must be transformed into something that does not conflict, since - these two things should be independent. + case FFEBLD_opCONCATENATE: + length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_intrinsic_len_ (ffebld_left (expr)), + ffecom_intrinsic_len_ (ffebld_right (expr))); + break; - The transformation is as follows. If the name does not contain - an underscore, there is no possible conflict, so just return. - If the name does contain an underscore, then transform it just - like we transform an external identifier. */ + case FFEBLD_opFUNCREF: + case FFEBLD_opCONVERT: + length = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_get_identifier_ (const char *name) -{ - /* If name does not contain an underscore, just return it as is. */ + default: + assert ("bad op for single char arg expr" == NULL); + length = ffecom_f2c_ftnlen_zero_node; + break; + } - if (!ffe_is_underscoring () - || (strchr (name, '_') == NULL)) - return get_identifier (name); + assert (length != NULL_TREE); - return ffecom_get_appended_identifier_ (ffe_is_second_underscore (), - name); + return length; } #endif -/* ffecom_gen_sfuncdef_ -- Generate definition of statement function - - tree t; - ffesymbol s; // kindFUNCTION, whereIMMEDIATE. - t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s), - ffesymbol_kindtype(s)); +/* Handle CHARACTER assignments. - Call after setting up containing function and getting trees for all - other symbols. */ + Generates code to do the assignment. Used by ordinary assignment + statement handler ffecom_let_stmt and by statement-function + handler to generate code for a statement function. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt) +static void +ffecom_let_char_ (tree dest_tree, tree dest_length, + ffetargetCharacterSize dest_size, ffebld source) { - ffebld expr = ffesymbol_sfexpr (s); - tree type; - tree func; - tree result; - bool charfunc = (bt == FFEINFO_basictypeCHARACTER); - static bool recurse = FALSE; - int yes; - int old_lineno = lineno; - char *old_input_filename = input_filename; + ffecomConcatList_ catlist; + tree source_length; + tree source_tree; + tree expr_tree; - ffecom_nested_entry_ = s; + if ((dest_tree == error_mark_node) + || (dest_length == error_mark_node)) + return; - /* For now, we don't have a handy pointer to where the sfunc is actually - defined, though that should be easy to add to an ffesymbol. (The - token/where info available might well point to the place where the type - of the sfunc is declared, especially if that precedes the place where - the sfunc itself is defined, which is typically the case.) We should - put out a null pointer rather than point somewhere wrong, but I want to - see how it works at this point. */ + assert (dest_tree != NULL_TREE); + assert (dest_length != NULL_TREE); - input_filename = ffesymbol_where_filename (s); - lineno = ffesymbol_where_filelinenum (s); + /* Source might be an opCONVERT, which just means it is a different size + than the destination. Since the underlying implementation here handles + that (directly or via the s_copy or s_cat run-time-library functions), + we don't need the "convenience" of an opCONVERT that tells us to + truncate or blank-pad, particularly since the resulting implementation + would probably be slower than otherwise. */ - /* Pretransform the expression so any newly discovered things belong to the - outer program unit, not to the statement function. */ + while (ffebld_op (source) == FFEBLD_opCONVERT) + source = ffebld_left (source); - ffecom_expr_transform_ (expr); + catlist = ffecom_concat_list_new_ (source, dest_size); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + ffecom_concat_list_kill_ (catlist); + source_tree = null_pointer_node; + source_length = ffecom_f2c_ftnlen_zero_node; + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); - /* Make sure no recursive invocation of this fn (a specific case of failing - to pretransform an sfunc's expression, i.e. where its expression - references another untransformed sfunc) happens. */ + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); + TREE_SIDE_EFFECTS (expr_tree) = 1; - assert (!recurse); - recurse = TRUE; + expand_expr_stmt (expr_tree); - yes = suspend_momentary (); + return; - push_f_function_context (); + case 1: /* The (fairly) easy case. */ + ffecom_char_args_ (&source_tree, &source_length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (source_tree != NULL_TREE); + assert (source_length != NULL_TREE); + + if ((source_tree == error_mark_node) + || (source_length == error_mark_node)) + return; + + if (dest_size == 1) + { + dest_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree); + dest_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree, + integer_one_node); + source_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree); + source_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree, + integer_one_node); - ffecom_push_calltemps (); + expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree); - if (charfunc) - type = void_type_node; - else - { - type = ffecom_tree_type[bt][kt]; - if (type == NULL_TREE) - type = integer_type_node; /* _sym_exec_transition reports - error. */ - } + expand_expr_stmt (expr_tree); - start_function (ffecom_get_identifier_ (ffesymbol_text (s)), - build_function_type (type, NULL_TREE), - 1, /* nested/inline */ - 0); /* TREE_PUBLIC */ + return; + } - /* We don't worry about COMPLEX return values here, because this is - entirely internal to our code, and gcc has the ability to return COMPLEX - directly as a value. */ + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); - yes = suspend_momentary (); + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE); + TREE_SIDE_EFFECTS (expr_tree) = 1; - if (charfunc) - { /* Prepend arg for where result goes. */ - tree type; + expand_expr_stmt (expr_tree); - type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + return; - result = ffecom_get_invented_identifier ("__g77_%s", - "result", 0); + default: /* Must actually concatenate things. */ + break; + } - ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ + /* Heavy-duty concatenation. */ - type = build_pointer_type (type); - result = build_decl (PARM_DECL, result, type); + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; - push_parm_decl (result); +#ifdef HOHO + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, + count, TRUE); +#else + { + tree hook; + + hook = ffebld_nonter_hook (source); + assert (hook); + assert (TREE_CODE (hook) == TREE_VEC); + assert (TREE_VEC_LENGTH (hook) == 2); + length_array = lengths = TREE_VEC_ELT (hook, 0); + item_array = items = TREE_VEC_ELT (hook, 1); } - else - result = NULL_TREE; /* Not ref'd if !charfunc. */ - - ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE); - - resume_momentary (yes); +#endif - store_parm_decls (0); + for (i = 0; i < count; ++i) + { + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + return; + } - ffecom_start_compstmt_ (); + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } - if (expr != NULL) - { - if (charfunc) - { - ffetargetCharacterSize sz = ffesymbol_size (s); - tree result_length; + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) + = build_tree_list (NULL_TREE, dest_length); - result_length = build_int_2 (sz, 0); - TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE); + TREE_SIDE_EFFECTS (expr_tree) = 1; - ffecom_let_char_ (result, result_length, sz, expr); - expand_null_return (); - } - else - expand_return (ffecom_modify (NULL_TREE, - DECL_RESULT (current_function_decl), - ffecom_expr (expr))); + expand_expr_stmt (expr_tree); + } - clear_momentary (); - } + ffecom_concat_list_kill_ (catlist); +} - ffecom_end_compstmt_ (); +#endif +/* ffecom_make_gfrt_ -- Make initial info for run-time routine - func = current_function_decl; - finish_function (1); + ffecomGfrt ix; + ffecom_make_gfrt_(ix); - ffecom_pop_calltemps (); + Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL + for the indicated run-time routine (ix). */ - pop_f_function_context (); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_make_gfrt_ (ffecomGfrt ix) +{ + tree t; + tree ttype; - resume_momentary (yes); + push_obstacks_nochange (); + end_temporary_allocation (); - recurse = FALSE; + switch (ffecom_gfrt_type_[ix]) + { + case FFECOM_rttypeVOID_: + ttype = void_type_node; + break; - lineno = old_lineno; - input_filename = old_input_filename; + case FFECOM_rttypeVOIDSTAR_: + ttype = TREE_TYPE (null_pointer_node); /* `void *'. */ + break; - ffecom_nested_entry_ = NULL; + case FFECOM_rttypeFTNINT_: + ttype = ffecom_f2c_ftnint_type_node; + break; - return func; -} + case FFECOM_rttypeINTEGER_: + ttype = ffecom_f2c_integer_type_node; + break; -#endif + case FFECOM_rttypeLONGINT_: + ttype = ffecom_f2c_longint_type_node; + break; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static const char * -ffecom_gfrt_args_ (ffecomGfrt ix) -{ - return ffecom_gfrt_argstring_[ix]; -} + case FFECOM_rttypeLOGICAL_: + ttype = ffecom_f2c_logical_type_node; + break; -#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_gfrt_tree_ (ffecomGfrt ix) -{ - if (ffecom_gfrt_[ix] == NULL_TREE) - ffecom_make_gfrt_ (ix); + case FFECOM_rttypeREAL_F2C_: + ttype = double_type_node; + break; - return ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])), - ffecom_gfrt_[ix]); -} + case FFECOM_rttypeREAL_GNU_: + ttype = float_type_node; + break; -#endif -/* Return initialize-to-zero expression for this VAR_DECL. */ + case FFECOM_rttypeCOMPLEX_F2C_: + ttype = void_type_node; + break; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_init_zero_ (tree decl) -{ - tree init; - int incremental = TREE_STATIC (decl); - tree type = TREE_TYPE (decl); + case FFECOM_rttypeCOMPLEX_GNU_: + ttype = ffecom_f2c_complex_type_node; + break; - if (incremental) - { - int momentary = suspend_momentary (); - push_obstacks_nochange (); - if (TREE_PERMANENT (decl)) - end_temporary_allocation (); - make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0); - assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); - pop_obstacks (); - resume_momentary (momentary); - } + case FFECOM_rttypeDOUBLE_: + ttype = double_type_node; + break; - push_momentary (); + case FFECOM_rttypeDOUBLEREAL_: + ttype = ffecom_f2c_doublereal_type_node; + break; - if ((TREE_CODE (type) != ARRAY_TYPE) - && (TREE_CODE (type) != RECORD_TYPE) - && (TREE_CODE (type) != UNION_TYPE) - && !incremental) - init = convert (type, integer_zero_node); - else if (!incremental) - { - int momentary = suspend_momentary (); + case FFECOM_rttypeDBLCMPLX_F2C_: + ttype = void_type_node; + break; - init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; + case FFECOM_rttypeDBLCMPLX_GNU_: + ttype = ffecom_f2c_doublecomplex_type_node; + break; - resume_momentary (momentary); + case FFECOM_rttypeCHARACTER_: + ttype = void_type_node; + break; + + default: + ttype = NULL; + assert ("bad rttype" == NULL); + break; } - else - { - int momentary = suspend_momentary (); - assemble_zeros (int_size_in_bytes (type)); - init = error_mark_node; + ttype = build_function_type (ttype, NULL_TREE); + t = build_decl (FUNCTION_DECL, + get_identifier (ffecom_gfrt_name_[ix]), + ttype); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; - resume_momentary (momentary); - } + t = start_decl (t, TRUE); - pop_momentary_nofree (); + finish_decl (t, NULL_TREE, TRUE); - return init; + resume_temporary_allocation (); + pop_obstacks (); + + ffecom_gfrt_[ix] = t; } #endif +/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ + #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, - tree *maybe_tree) +static void +ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) { - tree expr_tree; - tree length_tree; + ffesymbol s = ffestorag_symbol (st); - switch (ffebld_op (arg)) - { - case FFEBLD_opCONTER: /* For F90, check 0-length. */ - if (ffetarget_length_character1 - (ffebld_constant_character1 - (ffebld_conter (arg))) == 0) - { - *maybe_tree = integer_zero_node; - return convert (tree_type, integer_zero_node); - } + if (ffesymbol_namelisted (s)) + ffecom_member_namelisted_ = TRUE; +} - *maybe_tree = integer_one_node; - expr_tree = build_int_2 (*ffetarget_text_character1 - (ffebld_constant_character1 - (ffebld_conter (arg))), - 0); - TREE_TYPE (expr_tree) = tree_type; - return expr_tree; +#endif +/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare + the member so debugger will see it. Otherwise nobody should be + referencing the member. */ - case FFEBLD_opSYMTER: - case FFEBLD_opARRAYREF: - case FFEBLD_opFUNCREF: - case FFEBLD_opSUBSTR: - ffecom_push_calltemps (); - ffecom_char_args_ (&expr_tree, &length_tree, arg); - ffecom_pop_calltemps (); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING +static void +ffecom_member_phase2_ (ffestorag mst, ffestorag st) +{ + ffesymbol s; + tree t; + tree mt; + tree type; - if ((expr_tree == error_mark_node) - || (length_tree == error_mark_node)) - { - *maybe_tree = error_mark_node; - return error_mark_node; - } + if ((mst == NULL) + || ((mt = ffestorag_hook (mst)) == NULL) + || (mt == error_mark_node)) + return; - if (integer_zerop (length_tree)) - { - *maybe_tree = integer_zero_node; - return convert (tree_type, integer_zero_node); - } + if ((st == NULL) + || ((s = ffestorag_symbol (st)) == NULL)) + return; - expr_tree - = ffecom_1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), - expr_tree); - expr_tree - = ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), - expr_tree, - integer_one_node); - expr_tree = convert (tree_type, expr_tree); + type = ffecom_type_localvar_ (s, + ffesymbol_basictype (s), + ffesymbol_kindtype (s)); + if (type == error_mark_node) + return; - if (TREE_CODE (length_tree) == INTEGER_CST) - *maybe_tree = integer_one_node; - else /* Must check length at run time. */ - *maybe_tree - = ffecom_truth_value - (ffecom_2 (GT_EXPR, integer_type_node, - length_tree, - ffecom_f2c_ftnlen_zero_node)); - return expr_tree; + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); - case FFEBLD_opPAREN: - case FFEBLD_opCONVERT: - if (ffeinfo_size (ffebld_info (arg)) == 0) - { - *maybe_tree = integer_zero_node; - return convert (tree_type, integer_zero_node); - } - return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), - maybe_tree); + TREE_STATIC (t) = TREE_STATIC (mt); + DECL_INITIAL (t) = NULL_TREE; + TREE_ASM_WRITTEN (t) = 1; - case FFEBLD_opCONCATENATE: - { - tree maybe_left; - tree maybe_right; - tree expr_left; - tree expr_right; + DECL_RTL (t) + = gen_rtx (MEM, TYPE_MODE (type), + plus_constant (XEXP (DECL_RTL (mt), 0), + ffestorag_modulo (mst) + + ffestorag_offset (st) + - ffestorag_offset (mst))); - expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), - &maybe_left); - expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg), - &maybe_right); - *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, - maybe_left, - maybe_right); - expr_tree = ffecom_3 (COND_EXPR, tree_type, - maybe_left, - expr_left, - expr_right); - return expr_tree; - } + t = start_decl (t, FALSE); - default: - assert ("bad op in ICHAR" == NULL); - return error_mark_node; - } + finish_decl (t, NULL_TREE, FALSE); } #endif -/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN()) - - tree length_arg; - ffebld expr; - length_arg = ffecom_intrinsic_len_ (expr); - - Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF - subexpressions by constructing the appropriate tree for the - length-of-character-text argument in a calling sequence. */ +#endif +/* Prepare source expression for assignment into a destination perhaps known + to be of a specific size. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_intrinsic_len_ (ffebld expr) +static void +ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source) { - ffetargetCharacter1 val; - tree length; - - switch (ffebld_op (expr)) - { - case FFEBLD_opCONTER: - val = ffebld_constant_character1 (ffebld_conter (expr)); - length = build_int_2 (ffetarget_length_character1 (val), 0); - TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; - break; - - case FFEBLD_opSYMTER: - { - ffesymbol s = ffebld_symter (expr); - tree item; + ffecomConcatList_ catlist; + int count; + int i; + tree ltmp; + tree itmp; + tree tempvar = NULL_TREE; - item = ffesymbol_hook (s).decl_tree; - if (item == NULL_TREE) - { - s = ffecom_sym_transform_ (s); - item = ffesymbol_hook (s).decl_tree; - } - if (ffesymbol_kind (s) == FFEINFO_kindENTITY) - { - if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) - length = ffesymbol_hook (s).length_tree; - else - { - length = build_int_2 (ffesymbol_size (s), 0); - TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; - } - } - else if (item == error_mark_node) - length = error_mark_node; - else /* FFEINFO_kindFUNCTION: */ - length = NULL_TREE; - } - break; + while (ffebld_op (source) == FFEBLD_opCONVERT) + source = ffebld_left (source); - case FFEBLD_opARRAYREF: - length = ffecom_intrinsic_len_ (ffebld_left (expr)); - break; + catlist = ffecom_concat_list_new_ (source, dest_size); + count = ffecom_concat_list_count_ (catlist); - case FFEBLD_opSUBSTR: - { - ffebld start; - ffebld end; - ffebld thing = ffebld_right (expr); - tree start_tree; - tree end_tree; + if (count >= 2) + { + ltmp + = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count); + itmp + = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count); + + tempvar = make_tree_vec (2); + TREE_VEC_ELT (tempvar, 0) = ltmp; + TREE_VEC_ELT (tempvar, 1) = itmp; + } - assert (ffebld_op (thing) == FFEBLD_opITEM); - start = ffebld_head (thing); - thing = ffebld_trail (thing); - assert (ffebld_trail (thing) == NULL); - end = ffebld_head (thing); + for (i = 0; i < count; ++i) + ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i)); - length = ffecom_intrinsic_len_ (ffebld_left (expr)); + ffecom_concat_list_kill_ (catlist); - if (length == error_mark_node) - break; + if (tempvar) + { + ffebld_nonter_set_hook (source, tempvar); + current_binding_level->prep_state = 1; + } +} - if (start == NULL) - { - if (end == NULL) - ; - else - { - length = convert (ffecom_f2c_ftnlen_type_node, - ffecom_expr (end)); - } - } - else - { - start_tree = convert (ffecom_f2c_ftnlen_type_node, - ffecom_expr (start)); +/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order - if (start_tree == error_mark_node) - { - length = error_mark_node; - break; - } + Ignores STAR (alternate-return) dummies. All other get exec-transitioned + (which generates their trees) and then their trees get push_parm_decl'd. - if (end == NULL) - { - length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, - ffecom_f2c_ftnlen_one_node, - ffecom_2 (MINUS_EXPR, - ffecom_f2c_ftnlen_type_node, - length, - start_tree)); - } - else - { - end_tree = convert (ffecom_f2c_ftnlen_type_node, - ffecom_expr (end)); + The second arg is TRUE if the dummies are for a statement function, in + which case lengths are not pushed for character arguments (since they are + always known by both the caller and the callee, though the code allows + for someday permitting CHAR*(*) stmtfunc dummies). */ - if (end_tree == error_mark_node) - { - length = error_mark_node; - break; - } +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc) +{ + ffebld dummy; + ffebld dumlist; + ffesymbol s; + tree parm; - length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, - ffecom_f2c_ftnlen_one_node, - ffecom_2 (MINUS_EXPR, - ffecom_f2c_ftnlen_type_node, - end_tree, start_tree)); - } - } - } - break; + ffecom_transform_only_dummies_ = TRUE; - case FFEBLD_opCONCATENATE: - length - = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, - ffecom_intrinsic_len_ (ffebld_left (expr)), - ffecom_intrinsic_len_ (ffebld_right (expr))); - break; + /* First push the parms corresponding to actual dummy "contents". */ - case FFEBLD_opFUNCREF: - case FFEBLD_opCONVERT: - length = build_int_2 (ffebld_size (expr), 0); - TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; - break; + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns. */ - default: - assert ("bad op for single char arg expr" == NULL); - length = ffecom_f2c_ftnlen_zero_node; - break; + default: + break; + } + assert (ffebld_op (dummy) == FFEBLD_opSYMTER); + s = ffebld_symter (dummy); + parm = ffesymbol_hook (s).decl_tree; + if (parm == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + parm = ffesymbol_hook (s).decl_tree; + assert (parm != NULL_TREE); + } + if (parm != error_mark_node) + push_parm_decl (parm); } - assert (length != NULL_TREE); + /* Then, for CHARACTER dummies, push the parms giving their lengths. */ - return length; + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns, they mean + NOTHING! */ + + default: + break; + } + s = ffebld_symter (dummy); + if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) + continue; /* Only looking for CHARACTER arguments. */ + if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE)) + continue; /* Stmtfunc arg with known size needs no + length param. */ + if (ffesymbol_kind (s) != FFEINFO_kindENTITY) + continue; /* Only looking for variables and arrays. */ + parm = ffesymbol_hook (s).length_tree; + assert (parm != NULL_TREE); + if (parm != error_mark_node) + push_parm_decl (parm); + } + + ffecom_transform_only_dummies_ = FALSE; } #endif -/* ffecom_let_char_ -- Do assignment stuff for character type - - tree dest_tree; // destination (ADDR_EXPR) - tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL)) - ffetargetCharacterSize dest_size; // length - ffebld source; // source expression - ffecom_let_char_(dest_tree,dest_length,dest_size,source); +/* ffecom_start_progunit_ -- Beginning of program unit - Generates code to do the assignment. Used by ordinary assignment - statement handler ffecom_let_stmt and by statement-function - handler to generate code for a statement function. */ + Does GNU back end stuff necessary to teach it about the start of its + equivalent of a Fortran program unit. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static void -ffecom_let_char_ (tree dest_tree, tree dest_length, - ffetargetCharacterSize dest_size, ffebld source) +ffecom_start_progunit_ () { - ffecomConcatList_ catlist; - tree source_length; - tree source_tree; - tree expr_tree; + ffesymbol fn = ffecom_primary_entry_; + ffebld arglist; + tree id; /* Identifier (name) of function. */ + tree type; /* Type of function. */ + tree result; /* Result of function. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + ffeglobalType gt; + ffeglobalType egt = FFEGLOBAL_type; + bool charfunc; + bool cmplxfunc; + bool altentries = (ffecom_num_entrypoints_ != 0); + bool multi + = altentries + && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE); + bool main_program = FALSE; + int old_lineno = lineno; + char *old_input_filename = input_filename; + int yes; - if ((dest_tree == error_mark_node) - || (dest_length == error_mark_node)) - return; + assert (fn != NULL); + assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); - assert (dest_tree != NULL_TREE); - assert (dest_length != NULL_TREE); + input_filename = ffesymbol_where_filename (fn); + lineno = ffesymbol_where_filelinenum (fn); - /* Source might be an opCONVERT, which just means it is a different size - than the destination. Since the underlying implementation here handles - that (directly or via the s_copy or s_cat run-time-library functions), - we don't need the "convenience" of an opCONVERT that tells us to - truncate or blank-pad, particularly since the resulting implementation - would probably be slower than otherwise. */ + /* c-parse.y indeed does call suspend_momentary and not only ignores the + return value, but also never calls resume_momentary, when starting an + outer function (see "fndef:", "setspecs:", and so on). So g77 does the + same thing. It shouldn't be a problem since start_function calls + temporary_allocation, but it might be necessary. If it causes a problem + here, then maybe there's a bug lurking in gcc. NOTE: This identical + comment appears twice in thist file. */ + + suspend_momentary (); + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindPROGRAM: + main_program = TRUE; + gt = FFEGLOBAL_typeMAIN; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindBLOCKDATA: + gt = FFEGLOBAL_typeBDATA; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindFUNCTION: + gt = FFEGLOBAL_typeFUNC; + egt = FFEGLOBAL_typeEXT; + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + if (bt == FFEINFO_basictypeNONE) + { + ffeimplic_establish_symbol (fn); + if (ffesymbol_funcresult (fn) != NULL) + ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + } + + if (multi) + charfunc = cmplxfunc = FALSE; + else if (bt == FFEINFO_basictypeCHARACTER) + charfunc = TRUE, cmplxfunc = FALSE; + else if ((bt == FFEINFO_basictypeCOMPLEX) + && ffesymbol_is_f2c (fn) + && !altentries) + charfunc = FALSE, cmplxfunc = TRUE; + else + charfunc = cmplxfunc = FALSE; + + if (multi || charfunc) + type = ffecom_tree_fun_type_void; + else if (ffesymbol_is_f2c (fn) && !altentries) + type = ffecom_tree_fun_type[bt][kt]; + else + type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + if ((type == NULL_TREE) + || (TREE_TYPE (type) == NULL_TREE)) + type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ + break; + + case FFEINFO_kindSUBROUTINE: + gt = FFEGLOBAL_typeSUBR; + egt = FFEGLOBAL_typeEXT; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + if (ffecom_is_altreturning_) + type = ffecom_tree_subr_type; + else + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; - while (ffebld_op (source) == FFEBLD_opCONVERT) - source = ffebld_left (source); + default: + assert ("say what??" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + gt = FFEGLOBAL_typeANY; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = error_mark_node; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + } - catlist = ffecom_concat_list_new_ (source, dest_size); - switch (ffecom_concat_list_count_ (catlist)) + if (altentries) { - case 0: /* Shouldn't happen, but in case it does... */ - ffecom_concat_list_kill_ (catlist); - source_tree = null_pointer_node; - source_length = ffecom_f2c_ftnlen_zero_node; - expr_tree = build_tree_list (NULL_TREE, dest_tree); - TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); - TREE_CHAIN (TREE_CHAIN (expr_tree)) - = build_tree_list (NULL_TREE, dest_length); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) - = build_tree_list (NULL_TREE, source_length); + id = ffecom_get_invented_identifier ("__g77_masterfun_%s", + ffesymbol_text (fn), + -1); + } +#if FFETARGET_isENFORCED_MAIN + else if (main_program) + id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME); +#endif + else + id = ffecom_get_external_identifier_ (fn); - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); - TREE_SIDE_EFFECTS (expr_tree) = 1; + start_function (id, + type, + 0, /* nested/inline */ + !altentries); /* TREE_PUBLIC */ - expand_expr_stmt (expr_tree); + TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */ - return; + if (!altentries + && ((g = ffesymbol_global (fn)) != NULL) + && ((ffeglobal_type (g) == gt) + || (ffeglobal_type (g) == egt))) + { + ffeglobal_set_hook (g, current_function_decl); + } - case 1: /* The (fairly) easy case. */ - ffecom_char_args_ (&source_tree, &source_length, - ffecom_concat_list_expr_ (catlist, 0)); - ffecom_concat_list_kill_ (catlist); - assert (source_tree != NULL_TREE); - assert (source_length != NULL_TREE); + yes = suspend_momentary (); - if ((source_tree == error_mark_node) - || (source_length == error_mark_node)) - return; + /* Arg handling needs exec-transitioned ffesymbols to work with. But + exec-transitioning needs current_function_decl to be filled in. So we + do these things in two phases. */ - if (dest_size == 1) - { - dest_tree - = ffecom_1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE - (dest_tree))), - dest_tree); - dest_tree - = ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE - (dest_tree))), - dest_tree, - integer_one_node); - source_tree - = ffecom_1 (INDIRECT_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE - (source_tree))), - source_tree); - source_tree - = ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE - (source_tree))), - source_tree, - integer_one_node); + if (altentries) + { /* 1st arg identifies which entrypoint. */ + ffecom_which_entrypoint_decl_ + = build_decl (PARM_DECL, + ffecom_get_invented_identifier ("__g77_%s", + "which_entrypoint", + -1), + integer_type_node); + push_parm_decl (ffecom_which_entrypoint_decl_); + } - expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree); + if (charfunc + || cmplxfunc + || multi) + { /* Arg for result (return value). */ + tree type; + tree length; - expand_expr_stmt (expr_tree); + if (charfunc) + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + else if (cmplxfunc) + type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; + else + type = ffecom_multi_type_node_; - return; - } + result = ffecom_get_invented_identifier ("__g77_%s", + "result", -1); - expr_tree = build_tree_list (NULL_TREE, dest_tree); - TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); - TREE_CHAIN (TREE_CHAIN (expr_tree)) - = build_tree_list (NULL_TREE, dest_length); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) - = build_tree_list (NULL_TREE, source_length); + /* Make length arg _and_ enhance type info for CHAR arg itself. */ - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); - TREE_SIDE_EFFECTS (expr_tree) = 1; + if (charfunc) + length = ffecom_char_enhance_arg_ (&type, fn); + else + length = NULL_TREE; /* Not ref'd if !charfunc. */ - expand_expr_stmt (expr_tree); + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); - return; + push_parm_decl (result); + if (multi) + ffecom_multi_retval_ = result; + else + ffecom_func_result_ = result; - default: /* Must actually concatenate things. */ - break; + if (charfunc) + { + push_parm_decl (length); + ffecom_func_length_ = length; + } } - /* Heavy-duty concatenation. */ - - { - int count = ffecom_concat_list_count_ (catlist); - int i; - tree lengths; - tree items; - tree length_array; - tree item_array; - tree citem; - tree clength; - - length_array - = lengths - = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count, TRUE); - item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, - count, TRUE); + if (ffecom_primary_entry_is_proc_) + { + if (altentries) + arglist = ffecom_master_arglist_; + else + arglist = ffesymbol_dummyargs (fn); + ffecom_push_dummy_decls_ (arglist, FALSE); + } - for (i = 0; i < count; ++i) - { - ffecom_char_args_ (&citem, &clength, - ffecom_concat_list_expr_ (catlist, i)); - if ((citem == error_mark_node) - || (clength == error_mark_node)) - { - ffecom_concat_list_kill_ (catlist); - return; - } + resume_momentary (yes); - items - = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), - ffecom_modify (void_type_node, - ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), - item_array, - build_int_2 (i, 0)), - citem), - items); - lengths - = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), - ffecom_modify (void_type_node, - ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), - length_array, - build_int_2 (i, 0)), - clength), - lengths); - } + if (TREE_CODE (current_function_decl) != ERROR_MARK) + store_parm_decls (main_program ? 1 : 0); - expr_tree = build_tree_list (NULL_TREE, dest_tree); - TREE_CHAIN (expr_tree) - = build_tree_list (NULL_TREE, - ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (items)), - items)); - TREE_CHAIN (TREE_CHAIN (expr_tree)) - = build_tree_list (NULL_TREE, - ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (lengths)), - lengths)); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) - = build_tree_list - (NULL_TREE, - ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, - convert (ffecom_f2c_ftnlen_type_node, - build_int_2 (count, 0)))); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) - = build_tree_list (NULL_TREE, dest_length); + ffecom_start_compstmt (); + /* Disallow temp vars at this level. */ + current_binding_level->prep_state = 2; - expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree); - TREE_SIDE_EFFECTS (expr_tree) = 1; + lineno = old_lineno; + input_filename = old_input_filename; - expand_expr_stmt (expr_tree); - } + /* This handles any symbols still untransformed, in case -g specified. + This used to be done in ffecom_finish_progunit, but it turns out to + be necessary to do it here so that statement functions are + expanded before code. But don't bother for BLOCK DATA. */ - ffecom_concat_list_kill_ (catlist); + if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + ffesymbol_drive (ffecom_finish_symbol_transform_); } #endif -/* ffecom_make_gfrt_ -- Make initial info for run-time routine +/* ffecom_sym_transform_ -- Transform FFE sym into backend sym - ffecomGfrt ix; - ffecom_make_gfrt_(ix); + ffesymbol s; + ffecom_sym_transform_(s); + + The ffesymbol_hook info for s is updated with appropriate backend info + on the symbol. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_sym_transform_ (ffesymbol s) +{ + tree t; /* Transformed thingy. */ + tree tlen; /* Length if CHAR*(*). */ + bool addr; /* Is t the address of the thingy? */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; - Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL - for the indicated run-time routine (ix). */ + /* Must ensure special ASSIGN variables are declared at top of outermost + block, else they'll end up in the innermost block when their first + ASSIGN is seen, which leaves them out of scope when they're the + subject of a GOTO or I/O statement. -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_make_gfrt_ (ffecomGfrt ix) -{ - tree t; - tree ttype; + We make this variable even if -fugly-assign. Just let it go unused, + in case it turns out there are cases where we really want to use this + variable anyway (e.g. ASSIGN to INTEGER*2 variable). */ - push_obstacks_nochange (); - end_temporary_allocation (); + if (! ffecom_transform_only_dummies_ + && ffesymbol_assigned (s) + && ! ffesymbol_hook (s).assign_tree) + s = ffecom_sym_transform_assign_ (s); - switch (ffecom_gfrt_type_[ix]) + if (ffesymbol_sfdummyparent (s) == NULL) { - case FFECOM_rttypeVOID_: - ttype = void_type_node; - break; + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); - case FFECOM_rttypeVOIDSTAR_: - ttype = TREE_TYPE (null_pointer_node); /* `void *'. */ - break; + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } - case FFECOM_rttypeFTNINT_: - ttype = ffecom_f2c_ftnint_type_node; - break; + bt = ffeinfo_basictype (ffebld_info (s)); + kt = ffeinfo_kindtype (ffebld_info (s)); - case FFECOM_rttypeINTEGER_: - ttype = ffecom_f2c_integer_type_node; - break; + t = NULL_TREE; + tlen = NULL_TREE; + addr = FALSE; - case FFECOM_rttypeLONGINT_: - ttype = ffecom_f2c_longint_type_node; - break; + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindNONE: + switch (ffesymbol_where (s)) + { + case FFEINFO_whereDUMMY: /* Subroutine or function. */ + assert (ffecom_transform_only_dummies_); - case FFECOM_rttypeLOGICAL_: - ttype = ffecom_f2c_logical_type_node; - break; + /* Before 0.4, this could be ENTITY/DUMMY, but see + ffestu_sym_end_transition -- no longer true (in particular, if + it could be an ENTITY, it _will_ be made one, so that + possibility won't come through here). So we never make length + arg for CHARACTER type. */ - case FFECOM_rttypeREAL_F2C_: - ttype = double_type_node; - break; + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_ptr_to_subr_type); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; - case FFECOM_rttypeREAL_GNU_: - ttype = float_type_node; - break; + case FFEINFO_whereGLOBAL: /* Subroutine or function. */ + assert (!ffecom_transform_only_dummies_); - case FFECOM_rttypeCOMPLEX_F2C_: - ttype = void_type_node; - break; + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } - case FFECOM_rttypeCOMPLEX_GNU_: - ttype = ffecom_f2c_complex_type_node; - break; + push_obstacks_nochange (); + end_temporary_allocation (); - case FFECOM_rttypeDOUBLE_: - ttype = double_type_node; - break; + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); /* Assume subr. */ + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; - case FFECOM_rttypeDOUBLEREAL_: - ttype = ffecom_f2c_doublereal_type_node; - break; + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); - case FFECOM_rttypeDBLCMPLX_F2C_: - ttype = void_type_node; - break; + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); - case FFECOM_rttypeDBLCMPLX_GNU_: - ttype = ffecom_f2c_doublecomplex_type_node; - break; + resume_temporary_allocation (); + pop_obstacks (); - case FFECOM_rttypeCHARACTER_: - ttype = void_type_node; - break; + break; - default: - ttype = NULL; - assert ("bad rttype" == NULL); + default: + assert ("NONE where unexpected" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + break; + } break; - } - ttype = build_function_type (ttype, NULL_TREE); - t = build_decl (FUNCTION_DECL, - get_identifier (ffecom_gfrt_name_[ix]), - ttype); - DECL_EXTERNAL (t) = 1; - TREE_PUBLIC (t) = 1; - TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; + case FFEINFO_kindENTITY: + switch (ffeinfo_where (ffesymbol_info (s))) + { - t = start_decl (t, TRUE); + case FFEINFO_whereCONSTANT: + /* ~~Debugging info needed? */ + assert (!ffecom_transform_only_dummies_); + t = error_mark_node; /* Shouldn't ever see this in expr. */ + break; - finish_decl (t, NULL_TREE, TRUE); + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); - resume_temporary_allocation (); - pop_obstacks (); + { + ffestorag st = ffesymbol_storage (s); + tree type; - ffecom_gfrt_[ix] = t; -} + if ((st != NULL) + && (ffestorag_size (st) == 0)) + { + t = error_mark_node; + break; + } -#endif -/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */ + yes = suspend_momentary (); + type = ffecom_type_localvar_ (s, bt, kt); + resume_momentary (yes); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st) -{ - ffesymbol s = ffestorag_symbol (st); + if (type == error_mark_node) + { + t = error_mark_node; + break; + } - if (ffesymbol_namelisted (s)) - ffecom_member_namelisted_ = TRUE; -} + if ((st != NULL) + && (ffestorag_parent (st) != NULL)) + { /* Child of EQUIVALENCE parent. */ + ffestorag est; + tree et; + int yes; + ffetargetOffset offset; -#endif -/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare - the member so debugger will see it. Otherwise nobody should be - referencing the member. */ + est = ffestorag_parent (st); + ffecom_transform_equiv_ (est); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING -static void -ffecom_member_phase2_ (ffestorag mst, ffestorag st) -{ - ffesymbol s; - tree t; - tree mt; - tree type; + et = ffestorag_hook (est); + assert (et != NULL_TREE); - if ((mst == NULL) - || ((mt = ffestorag_hook (mst)) == NULL) - || (mt == error_mark_node)) - return; + if (! TREE_STATIC (et)) + put_var_into_stack (et); - if ((st == NULL) - || ((s = ffestorag_symbol (st)) == NULL)) - return; + yes = suspend_momentary (); - type = ffecom_type_localvar_ (s, - ffesymbol_basictype (s), - ffesymbol_kindtype (s)); - if (type == error_mark_node) - return; + offset = ffestorag_modulo (est) + + ffestorag_offset (ffesymbol_storage (s)) + - ffestorag_offset (est); - t = build_decl (VAR_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - type); + ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset); - TREE_STATIC (t) = TREE_STATIC (mt); - DECL_INITIAL (t) = NULL_TREE; - TREE_ASM_WRITTEN (t) = 1; + /* (t_type *) (((char *) &et) + offset) */ - DECL_RTL (t) - = gen_rtx (MEM, TYPE_MODE (type), - plus_constant (XEXP (DECL_RTL (mt), 0), - ffestorag_modulo (mst) - + ffestorag_offset (st) - - ffestorag_offset (mst))); + t = convert (string_type_node, /* (char *) */ + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (et)), + et)); + t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), + t, + build_int_2 (offset, 0)); + t = convert (build_pointer_type (type), + t); - t = start_decl (t, FALSE); + addr = TRUE; - finish_decl (t, NULL_TREE, FALSE); -} + resume_momentary (yes); + } + else + { + tree initexpr; + bool init = ffesymbol_is_init (s); -#endif -#endif -/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order + yes = suspend_momentary (); - Ignores STAR (alternate-return) dummies. All other get exec-transitioned - (which generates their trees) and then their trees get push_parm_decl'd. + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); - The second arg is TRUE if the dummies are for a statement function, in - which case lengths are not pushed for character arguments (since they are - always known by both the caller and the callee, though the code allows - for someday permitting CHAR*(*) stmtfunc dummies). */ + if (init + || ffesymbol_namelisted (s) +#ifdef FFECOM_sizeMAXSTACKITEM + || ((st != NULL) + && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ + != FFEINFO_kindBLOCKDATA) + && (ffesymbol_is_save (s) || ffe_is_saveall ()))) + TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE); + else + TREE_STATIC (t) = 0; /* No need to make static. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc) -{ - ffebld dummy; - ffebld dumlist; - ffesymbol s; - tree parm; + if (init || ffe_is_init_local_zero ()) + DECL_INITIAL (t) = error_mark_node; - ffecom_transform_only_dummies_ = TRUE; + /* Keep -Wunused from complaining about var if it + is used as sfunc arg or DATA implied-DO. */ + if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG) + DECL_IN_SYSTEM_HEADER (t) = 1; - /* First push the parms corresponding to actual dummy "contents". */ + t = start_decl (t, FALSE); - for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) - { - dummy = ffebld_head (dumlist); - switch (ffebld_op (dummy)) - { - case FFEBLD_opSTAR: - case FFEBLD_opANY: - continue; /* Forget alternate returns. */ + if (init) + { + if (ffesymbol_init (s) != NULL) + initexpr = ffecom_expr (ffesymbol_init (s)); + else + initexpr = ffecom_init_zero_ (t); + } + else if (ffe_is_init_local_zero ()) + initexpr = ffecom_init_zero_ (t); + else + initexpr = NULL_TREE; /* Not ref'd if !init. */ - default: - break; - } - assert (ffebld_op (dummy) == FFEBLD_opSYMTER); - s = ffebld_symter (dummy); - parm = ffesymbol_hook (s).decl_tree; - if (parm == NULL_TREE) - { - s = ffecom_sym_transform_ (s); - parm = ffesymbol_hook (s).decl_tree; - assert (parm != NULL_TREE); - } - if (parm != error_mark_node) - push_parm_decl (parm); - } + finish_decl (t, initexpr, FALSE); - /* Then, for CHARACTER dummies, push the parms giving their lengths. */ + if ((st != NULL) && (DECL_SIZE (t) != error_mark_node)) + { + tree size_tree; - for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) - { - dummy = ffebld_head (dumlist); - switch (ffebld_op (dummy)) - { - case FFEBLD_opSTAR: - case FFEBLD_opANY: - continue; /* Forget alternate returns, they mean - NOTHING! */ + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (t), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st)); + } - default: + resume_momentary (yes); + } + } break; - } - s = ffebld_symter (dummy); - if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) - continue; /* Only looking for CHARACTER arguments. */ - if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE)) - continue; /* Stmtfunc arg with known size needs no - length param. */ - if (ffesymbol_kind (s) != FFEINFO_kindENTITY) - continue; /* Only looking for variables and arrays. */ - parm = ffesymbol_hook (s).length_tree; - assert (parm != NULL_TREE); - if (parm != error_mark_node) - push_parm_decl (parm); - } - - ffecom_transform_only_dummies_ = FALSE; -} -#endif -/* ffecom_start_progunit_ -- Beginning of program unit + case FFEINFO_whereRESULT: + assert (!ffecom_transform_only_dummies_); - Does GNU back end stuff necessary to teach it about the start of its - equivalent of a Fortran program unit. */ + if (bt == FFEINFO_basictypeCHARACTER) + { /* Result is already in list of dummies, use + it (& length). */ + t = ffecom_func_result_; + tlen = ffecom_func_length_; + addr = TRUE; + break; + } + if ((ffecom_num_entrypoints_ == 0) + && (bt == FFEINFO_basictypeCOMPLEX) + && (ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Result is already in list of dummies, use + it. */ + t = ffecom_func_result_; + addr = TRUE; + break; + } + if (ffecom_func_result_ != NULL_TREE) + { + t = ffecom_func_result_; + break; + } + if ((ffecom_num_entrypoints_ != 0) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE)) + { + yes = suspend_momentary (); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_start_progunit_ () -{ - ffesymbol fn = ffecom_primary_entry_; - ffebld arglist; - tree id; /* Identifier (name) of function. */ - tree type; /* Type of function. */ - tree result; /* Result of function. */ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffeglobal g; - ffeglobalType gt; - ffeglobalType egt = FFEGLOBAL_type; - bool charfunc; - bool cmplxfunc; - bool altentries = (ffecom_num_entrypoints_ != 0); - bool multi - = altentries - && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) - && (ffecom_master_bt_ == FFEINFO_basictypeNONE); - bool main_program = FALSE; - int old_lineno = lineno; - char *old_input_filename = input_filename; - int yes; + assert (ffecom_multi_retval_ != NULL_TREE); + t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_, + ffecom_multi_retval_); + t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt], + t, ffecom_multi_fields_[bt][kt]); - assert (fn != NULL); - assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); + resume_momentary (yes); + break; + } - input_filename = ffesymbol_where_filename (fn); - lineno = ffesymbol_where_filelinenum (fn); + yes = suspend_momentary (); - /* c-parse.y indeed does call suspend_momentary and not only ignores the - return value, but also never calls resume_momentary, when starting an - outer function (see "fndef:", "setspecs:", and so on). So g77 does the - same thing. It shouldn't be a problem since start_function calls - temporary_allocation, but it might be necessary. If it causes a problem - here, then maybe there's a bug lurking in gcc. NOTE: This identical - comment appears twice in thist file. */ + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_type[bt][kt]); + TREE_STATIC (t) = 0; /* Put result on stack. */ + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); - suspend_momentary (); + ffecom_func_result_ = t; - switch (ffecom_primary_entry_kind_) - { - case FFEINFO_kindPROGRAM: - main_program = TRUE; - gt = FFEGLOBAL_typeMAIN; - bt = FFEINFO_basictypeNONE; - kt = FFEINFO_kindtypeNONE; - type = ffecom_tree_fun_type_void; - charfunc = FALSE; - cmplxfunc = FALSE; - break; + resume_momentary (yes); + break; - case FFEINFO_kindBLOCKDATA: - gt = FFEGLOBAL_typeBDATA; - bt = FFEINFO_basictypeNONE; - kt = FFEINFO_kindtypeNONE; - type = ffecom_tree_fun_type_void; - charfunc = FALSE; - cmplxfunc = FALSE; - break; + case FFEINFO_whereDUMMY: + { + tree type; + ffebld dl; + ffebld dim; + tree low; + tree high; + tree old_sizes; + bool adjustable = FALSE; /* Conditionally adjustable? */ - case FFEINFO_kindFUNCTION: - gt = FFEGLOBAL_typeFUNC; - egt = FFEGLOBAL_typeEXT; - bt = ffesymbol_basictype (fn); - kt = ffesymbol_kindtype (fn); - if (bt == FFEINFO_basictypeNONE) - { - ffeimplic_establish_symbol (fn); - if (ffesymbol_funcresult (fn) != NULL) - ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); - bt = ffesymbol_basictype (fn); - kt = ffesymbol_kindtype (fn); - } + type = ffecom_tree_type[bt][kt]; + if (ffesymbol_sfdummyparent (s) != NULL) + { + if (current_function_decl == ffecom_outer_function_decl_) + { /* Exec transition before sfunc + context; get it later. */ + break; + } + t = ffecom_get_identifier_ (ffesymbol_text + (ffesymbol_sfdummyparent (s))); + } + else + t = ffecom_get_identifier_ (ffesymbol_text (s)); - if (multi) - charfunc = cmplxfunc = FALSE; - else if (bt == FFEINFO_basictypeCHARACTER) - charfunc = TRUE, cmplxfunc = FALSE; - else if ((bt == FFEINFO_basictypeCOMPLEX) - && ffesymbol_is_f2c (fn) - && !altentries) - charfunc = FALSE, cmplxfunc = TRUE; - else - charfunc = cmplxfunc = FALSE; + assert (ffecom_transform_only_dummies_); - if (multi || charfunc) - type = ffecom_tree_fun_type_void; - else if (ffesymbol_is_f2c (fn) && !altentries) - type = ffecom_tree_fun_type[bt][kt]; - else - type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + old_sizes = get_pending_sizes (); + put_pending_sizes (old_sizes); - if ((type == NULL_TREE) - || (TREE_TYPE (type) == NULL_TREE)) - type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ - break; + if (bt == FFEINFO_basictypeCHARACTER) + tlen = ffecom_char_enhance_arg_ (&type, s); + type = ffecom_check_size_overflow_ (s, type, TRUE); - case FFEINFO_kindSUBROUTINE: - gt = FFEGLOBAL_typeSUBR; - egt = FFEGLOBAL_typeEXT; - bt = FFEINFO_basictypeNONE; - kt = FFEINFO_kindtypeNONE; - if (ffecom_is_altreturning_) - type = ffecom_tree_subr_type; - else - type = ffecom_tree_fun_type_void; - charfunc = FALSE; - cmplxfunc = FALSE; - break; + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; - default: - assert ("say what??" == NULL); - /* Fall through. */ - case FFEINFO_kindANY: - gt = FFEGLOBAL_typeANY; - bt = FFEINFO_basictypeNONE; - kt = FFEINFO_kindtypeNONE; - type = error_mark_node; - charfunc = FALSE; - cmplxfunc = FALSE; - break; - } + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (dim)); + assert (ffebld_right (dim) != NULL); + if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR) + || ffecom_doing_entry_) + { + /* Used to just do high=low. But for ffecom_tree_ + canonize_ref_, it probably is important to correctly + assess the size. E.g. given COMPLEX C(*),CFUNC and + C(2)=CFUNC(C), overlap can happen, while it can't + for, say, C(1)=CFUNC(C(2)). */ + /* Even more recently used to set to INT_MAX, but that + broke when some overflow checking went into the back + end. Now we just leave the upper bound unspecified. */ + high = NULL; + } + else + high = ffecom_expr (ffebld_right (dim)); - if (altentries) - { - id = ffecom_get_invented_identifier ("__g77_masterfun_%s", - ffesymbol_text (fn), - 0); - } -#if FFETARGET_isENFORCED_MAIN - else if (main_program) - id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME); -#endif - else - id = ffecom_get_external_identifier_ (fn); + /* Determine whether array is conditionally adjustable, + to decide whether back-end magic is needed. - start_function (id, - type, - 0, /* nested/inline */ - !altentries); /* TREE_PUBLIC */ + Normally the front end uses the back-end function + variable_size to wrap SAVE_EXPR's around expressions + affecting the size/shape of an array so that the + size/shape info doesn't change during execution + of the compiled code even though variables and + functions referenced in those expressions might. - TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */ + variable_size also makes sure those saved expressions + get evaluated immediately upon entry to the + compiled procedure -- the front end normally doesn't + have to worry about that. - if (!altentries - && ((g = ffesymbol_global (fn)) != NULL) - && ((ffeglobal_type (g) == gt) - || (ffeglobal_type (g) == egt))) - { - ffeglobal_set_hook (g, current_function_decl); - } + However, there is a problem with this that affects + g77's implementation of entry points, and that is + that it is _not_ true that each invocation of the + compiled procedure is permitted to evaluate + array size/shape info -- because it is possible + that, for some invocations, that info is invalid (in + which case it is "promised" -- i.e. a violation of + the Fortran standard -- that the compiled code + won't reference the array or its size/shape + during that particular invocation). - yes = suspend_momentary (); + To phrase this in C terms, consider this gcc function: - /* Arg handling needs exec-transitioned ffesymbols to work with. But - exec-transitioning needs current_function_decl to be filled in. So we - do these things in two phases. */ + void foo (int *n, float (*a)[*n]) + { + // a is "pointer to array ...", fyi. + } - if (altentries) - { /* 1st arg identifies which entrypoint. */ - ffecom_which_entrypoint_decl_ - = build_decl (PARM_DECL, - ffecom_get_invented_identifier ("__g77_%s", - "which_entrypoint", - 0), - integer_type_node); - push_parm_decl (ffecom_which_entrypoint_decl_); - } + Suppose that, for some invocations, it is permitted + for a caller of foo to do this: - if (charfunc - || cmplxfunc - || multi) - { /* Arg for result (return value). */ - tree type; - tree length; + foo (NULL, NULL); - if (charfunc) - type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; - else if (cmplxfunc) - type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; - else - type = ffecom_multi_type_node_; + Now the _written_ code for foo can take such a call + into account by either testing explicitly for whether + (a == NULL) || (n == NULL) -- presumably it is + not permitted to reference *a in various fashions + if (n == NULL) I suppose -- or it can avoid it by + looking at other info (other arguments, static/global + data, etc.). - result = ffecom_get_invented_identifier ("__g77_%s", - "result", 0); + However, this won't work in gcc 2.5.8 because it'll + automatically emit the code to save the "*n" + expression, which'll yield a NULL dereference for + the "foo (NULL, NULL)" call, something the code + for foo cannot prevent. - /* Make length arg _and_ enhance type info for CHAR arg itself. */ + g77 definitely needs to avoid executing such + code anytime the pointer to the adjustable array + is NULL, because even if its bounds expressions + don't have any references to possible "absent" + variables like "*n" -- say all variable references + are to COMMON variables, i.e. global (though in C, + local static could actually make sense) -- the + expressions could yield other run-time problems + for allowably "dead" values in those variables. - if (charfunc) - length = ffecom_char_enhance_arg_ (&type, fn); - else - length = NULL_TREE; /* Not ref'd if !charfunc. */ + For example, let's consider a more complicated + version of foo: - type = build_pointer_type (type); - result = build_decl (PARM_DECL, result, type); + extern int i; + extern int j; - push_parm_decl (result); - if (multi) - ffecom_multi_retval_ = result; - else - ffecom_func_result_ = result; + void foo (float (*a)[i/j]) + { + ... + } - if (charfunc) - { - push_parm_decl (length); - ffecom_func_length_ = length; - } - } + The above is (essentially) quite valid for Fortran + but, again, for a call like "foo (NULL);", it is + permitted for i and j to be undefined when the + call is made. If j happened to be zero, for + example, emitting the code to evaluate "i/j" + could result in a run-time error. - if (ffecom_primary_entry_is_proc_) - { - if (altentries) - arglist = ffecom_master_arglist_; - else - arglist = ffesymbol_dummyargs (fn); - ffecom_push_dummy_decls_ (arglist, FALSE); - } + Offhand, though I don't have my F77 or F90 + standards handy, it might even be valid for a + bounds expression to contain a function reference, + in which case I doubt it is permitted for an + implementation to invoke that function in the + Fortran case involved here (invocation of an + alternate ENTRY point that doesn't have the adjustable + array as one of its arguments). - resume_momentary (yes); + So, the code that the compiler would normally emit + to preevaluate the size/shape info for an + adjustable array _must not_ be executed at run time + in certain cases. Specifically, for Fortran, + the case is when the pointer to the adjustable + array == NULL. (For gnu-ish C, it might be nice + for the source code itself to specify an expression + that, if TRUE, inhibits execution of the code. Or + reverse the sense for elegance.) - if (TREE_CODE (current_function_decl) != ERROR_MARK) - store_parm_decls (main_program ? 1 : 0); + (Note that g77 could use a different test than NULL, + actually, since it happens to always pass an + integer to the called function that specifies which + entry point is being invoked. Hmm, this might + solve the next problem.) + + One way a user could, I suppose, write "foo" so + it works is to insert COND_EXPR's for the + size/shape info so the dangerous stuff isn't + actually done, as in: + + void foo (int *n, float (*a)[(a == NULL) ? 0 : *n]) + { + ... + } - ffecom_start_compstmt_ (); + The next problem is that the front end needs to + be able to tell the back end about the array's + decl _before_ it tells it about the conditional + expression to inhibit evaluation of size/shape info, + as shown above. - lineno = old_lineno; - input_filename = old_input_filename; + To solve this, the front end needs to be able + to give the back end the expression to inhibit + generation of the preevaluation code _after_ + it makes the decl for the adjustable array. - /* This handles any symbols still untransformed, in case -g specified. - This used to be done in ffecom_finish_progunit, but it turns out to - be necessary to do it here so that statement functions are - expanded before code. But don't bother for BLOCK DATA. */ + Until then, the above example using the COND_EXPR + doesn't pass muster with gcc because the "(a == NULL)" + part has a reference to "a", which is still + undefined at that point. - if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) - ffesymbol_drive (ffecom_finish_symbol_transform_); -} + g77 will therefore use a different mechanism in the + meantime. */ -#endif -/* ffecom_sym_transform_ -- Transform FFE sym into backend sym + if (!adjustable + && ((TREE_CODE (low) != INTEGER_CST) + || (high && TREE_CODE (high) != INTEGER_CST))) + adjustable = TRUE; - ffesymbol s; - ffecom_sym_transform_(s); +#if 0 /* Old approach -- see below. */ + if (TREE_CODE (low) != INTEGER_CST) + low = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + low, + ffecom_integer_zero_node); - The ffesymbol_hook info for s is updated with appropriate backend info - on the symbol. */ + if (high && TREE_CODE (high) != INTEGER_CST) + high = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + high, + ffecom_integer_zero_node); +#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static ffesymbol -ffecom_sym_transform_ (ffesymbol s) -{ - tree t; /* Transformed thingy. */ - tree tlen; /* Length if CHAR*(*). */ - bool addr; /* Is t the address of the thingy? */ - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffeglobal g; - int yes; - int old_lineno = lineno; - char *old_input_filename = input_filename; + /* ~~~gcc/stor-layout.c (layout_type) should do this, + probably. Fixes 950302-1.f. */ - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - lineno = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); + if (TREE_CODE (low) != INTEGER_CST) + low = variable_size (low); - input_filename = ffesymbol_where_filename (sf); - lineno = ffesymbol_where_filelinenum (sf); - } + /* ~~~Similarly, this fixes dumb0.f. The C front end + does this, which is why dumb0.c would work. */ - bt = ffeinfo_basictype (ffebld_info (s)); - kt = ffeinfo_kindtype (ffebld_info (s)); + if (high && TREE_CODE (high) != INTEGER_CST) + high = variable_size (high); - t = NULL_TREE; - tlen = NULL_TREE; - addr = FALSE; + type + = build_array_type + (type, + build_range_type (ffecom_integer_type_node, + low, high)); + type = ffecom_check_size_overflow_ (s, type, TRUE); + } - switch (ffesymbol_kind (s)) - { - case FFEINFO_kindNONE: - switch (ffesymbol_where (s)) - { - case FFEINFO_whereDUMMY: /* Subroutine or function. */ - assert (ffecom_transform_only_dummies_); + if (type == error_mark_node) + { + t = error_mark_node; + break; + } - /* Before 0.4, this could be ENTITY/DUMMY, but see - ffestu_sym_end_transition -- no longer true (in particular, if - it could be an ENTITY, it _will_ be made one, so that - possibility won't come through here). So we never make length - arg for CHARACTER type. */ + if ((ffesymbol_sfdummyparent (s) == NULL) + || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) + { + type = build_pointer_type (type); + addr = TRUE; + } - t = build_decl (PARM_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - ffecom_tree_ptr_to_subr_type); + t = build_decl (PARM_DECL, t, type); #if BUILT_FOR_270 - DECL_ARTIFICIAL (t) = 1; + DECL_ARTIFICIAL (t) = 1; #endif - addr = TRUE; - break; - case FFEINFO_whereGLOBAL: /* Subroutine or function. */ - assert (!ffecom_transform_only_dummies_); + /* If this arg is present in every entry point's list of + dummy args, then we're done. */ - if (((g = ffesymbol_global (s)) != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) - && (ffeglobal_hook (g) != NULL_TREE) - && ffe_is_globals ()) - { - t = ffeglobal_hook (g); + if (ffesymbol_numentries (s) + == (ffecom_num_entrypoints_ + 1)) break; - } - push_obstacks_nochange (); - end_temporary_allocation (); +#if 1 - t = build_decl (FUNCTION_DECL, - ffecom_get_external_identifier_ (s), - ffecom_tree_subr_type); /* Assume subr. */ - DECL_EXTERNAL (t) = 1; - TREE_PUBLIC (t) = 1; + /* If variable_size in stor-layout has been called during + the above, then get_pending_sizes should have the + yet-to-be-evaluated saved expressions pending. + Make the whole lot of them get emitted, conditionally + on whether the array decl ("t" above) is not NULL. */ - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + { + tree sizes = get_pending_sizes (); + tree tem; - if ((g != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) - ffeglobal_set_hook (g, t); + for (tem = sizes; + tem != old_sizes; + tem = TREE_CHAIN (tem)) + { + tree temv = TREE_VALUE (tem); - resume_temporary_allocation (); - pop_obstacks (); + if (sizes == tem) + sizes = temv; + else + sizes + = ffecom_2 (COMPOUND_EXPR, + TREE_TYPE (sizes), + temv, + sizes); + } - break; + if (sizes != tem) + { + sizes + = ffecom_3 (COND_EXPR, + TREE_TYPE (sizes), + ffecom_2 (NE_EXPR, + integer_type_node, + t, + null_pointer_node), + sizes, + convert (TREE_TYPE (sizes), + integer_zero_node)); + sizes = ffecom_save_tree (sizes); - default: - assert ("NONE where unexpected" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - break; - } - break; + sizes + = tree_cons (NULL_TREE, sizes, tem); + } - case FFEINFO_kindENTITY: - switch (ffeinfo_where (ffesymbol_info (s))) - { + if (sizes) + put_pending_sizes (sizes); + } - case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */ - assert (!ffecom_transform_only_dummies_); - t = error_mark_node; /* Shouldn't ever see this in expr. */ +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + DECL_SOMETHING (t) + = ffecom_2 (NE_EXPR, integer_type_node, + t, + null_pointer_node); +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + { + ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } +#endif +#endif +#endif + } break; - case FFEINFO_whereLOCAL: - assert (!ffecom_transform_only_dummies_); - + case FFEINFO_whereCOMMON: { + ffesymbol cs; + ffeglobal cg; + tree ct; ffestorag st = ffesymbol_storage (s); tree type; + int yes; - if ((st != NULL) - && (ffestorag_size (st) == 0)) - { - t = error_mark_node; - break; - } - - yes = suspend_momentary (); - type = ffecom_type_localvar_ (s, bt, kt); - resume_momentary (yes); - - if (type == error_mark_node) + cs = ffesymbol_common (s); /* The COMMON area itself. */ + if (st != NULL) /* Else not laid out. */ { - t = error_mark_node; - break; + ffecom_transform_common_ (cs); + st = ffesymbol_storage (s); } - if ((st != NULL) - && (ffestorag_parent (st) != NULL)) - { /* Child of EQUIVALENCE parent. */ - ffestorag est; - tree et; - int yes; - ffetargetOffset offset; + yes = suspend_momentary (); - est = ffestorag_parent (st); - ffecom_transform_equiv_ (est); + type = ffecom_type_localvar_ (s, bt, kt); - et = ffestorag_hook (est); - assert (et != NULL_TREE); + cg = ffesymbol_global (cs); /* The global COMMON info. */ + if ((cg == NULL) + || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON)) + ct = NULL_TREE; + else + ct = ffeglobal_hook (cg); /* The common area's tree. */ - if (! TREE_STATIC (et)) - put_var_into_stack (et); + if ((ct == NULL_TREE) + || (st == NULL) + || (type == error_mark_node)) + t = error_mark_node; + else + { + ffetargetOffset offset; + ffestorag cst; - yes = suspend_momentary (); + cst = ffestorag_parent (st); + assert (cst == ffesymbol_storage (cs)); - offset = ffestorag_modulo (est) - + ffestorag_offset (ffesymbol_storage (s)) - - ffestorag_offset (est); + offset = ffestorag_modulo (cst) + + ffestorag_offset (st) + - ffestorag_offset (cst); - ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset); + ffecom_debug_kludge_ (ct, "COMMON", s, type, offset); - /* (t_type *) (((char *) &et) + offset) */ + /* (t_type *) (((char *) &ct) + offset) */ t = convert (string_type_node, /* (char *) */ ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (et)), - et)); + build_pointer_type (TREE_TYPE (ct)), + ct)); t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), t, build_int_2 (offset, 0)); @@ -8211,8315 +7932,9190 @@ ffecom_sym_transform_ (ffesymbol s) t); addr = TRUE; - - resume_momentary (yes); } - else - { - tree initexpr; - bool init = ffesymbol_is_init (s); - - yes = suspend_momentary (); - - t = build_decl (VAR_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - type); - - if (init - || ffesymbol_namelisted (s) -#ifdef FFECOM_sizeMAXSTACKITEM - || ((st != NULL) - && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)) -#endif - || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) - && (ffecom_primary_entry_kind_ - != FFEINFO_kindBLOCKDATA) - && (ffesymbol_is_save (s) || ffe_is_saveall ()))) - TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE); - else - TREE_STATIC (t) = 0; /* No need to make static. */ - - if (init || ffe_is_init_local_zero ()) - DECL_INITIAL (t) = error_mark_node; - - /* Keep -Wunused from complaining about var if it - is used as sfunc arg or DATA implied-DO. */ - if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG) - DECL_IN_SYSTEM_HEADER (t) = 1; - - t = start_decl (t, FALSE); - - if (init) - { - if (ffesymbol_init (s) != NULL) - initexpr = ffecom_expr (ffesymbol_init (s)); - else - initexpr = ffecom_init_zero_ (t); - } - else if (ffe_is_init_local_zero ()) - initexpr = ffecom_init_zero_ (t); - else - initexpr = NULL_TREE; /* Not ref'd if !init. */ - - finish_decl (t, initexpr, FALSE); - if ((st != NULL) && (DECL_SIZE (t) != error_mark_node)) - { - tree size_tree; + resume_momentary (yes); + } + break; - size_tree = size_binop (CEIL_DIV_EXPR, - DECL_SIZE (t), - size_int (BITS_PER_UNIT)); - assert (TREE_INT_CST_HIGH (size_tree) == 0); - assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st)); - } + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("ENTITY where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - resume_momentary (yes); - } - } + case FFEINFO_kindFUNCTION: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; break; - case FFEINFO_whereRESULT: + case FFEINFO_whereGLOBAL: assert (!ffecom_transform_only_dummies_); - if (bt == FFEINFO_basictypeCHARACTER) - { /* Result is already in list of dummies, use - it (& length). */ - t = ffecom_func_result_; - tlen = ffecom_func_length_; - addr = TRUE; - break; - } - if ((ffecom_num_entrypoints_ == 0) - && (bt == FFEINFO_basictypeCOMPLEX) - && (ffesymbol_is_f2c (ffecom_primary_entry_))) - { /* Result is already in list of dummies, use - it. */ - t = ffecom_func_result_; - addr = TRUE; - break; - } - if (ffecom_func_result_ != NULL_TREE) + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) { - t = ffecom_func_result_; + t = ffeglobal_hook (g); break; } - if ((ffecom_num_entrypoints_ != 0) - && (ffecom_master_bt_ == FFEINFO_basictypeNONE)) - { - yes = suspend_momentary (); - assert (ffecom_multi_retval_ != NULL_TREE); - t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_, - ffecom_multi_retval_); - t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt], - t, ffecom_multi_fields_[bt][kt]); + push_obstacks_nochange (); + end_temporary_allocation (); - resume_momentary (yes); - break; - } + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_fun_type[bt][kt]; + else + t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); - yes = suspend_momentary (); + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + t); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; - t = build_decl (VAR_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - ffecom_tree_type[bt][kt]); - TREE_STATIC (t) = 0; /* Put result on stack. */ t = start_decl (t, FALSE); finish_decl (t, NULL_TREE, FALSE); - ffecom_func_result_ = t; + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); - resume_momentary (yes); break; case FFEINFO_whereDUMMY: - { - tree type; - ffebld dl; - ffebld dim; - tree low; - tree high; - tree old_sizes; - bool adjustable = FALSE; /* Conditionally adjustable? */ + assert (ffecom_transform_only_dummies_); - type = ffecom_tree_type[bt][kt]; - if (ffesymbol_sfdummyparent (s) != NULL) - { - if (current_function_decl == ffecom_outer_function_decl_) - { /* Exec transition before sfunc - context; get it later. */ - break; - } - t = ffecom_get_identifier_ (ffesymbol_text - (ffesymbol_sfdummyparent (s))); - } - else - t = ffecom_get_identifier_ (ffesymbol_text (s)); + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_ptr_to_fun_type[bt][kt]; + else + t = build_pointer_type + (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE)); + + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + t); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; + + case FFEINFO_whereCONSTANT: /* Statement function. */ + assert (!ffecom_transform_only_dummies_); + t = ffecom_gen_sfuncdef_ (s, bt, kt); + break; + + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ + + default: + assert ("FUNCTION where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindSUBROUTINE: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; - assert (ffecom_transform_only_dummies_); + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); - old_sizes = get_pending_sizes (); - put_pending_sizes (old_sizes); + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } - if (bt == FFEINFO_basictypeCHARACTER) - tlen = ffecom_char_enhance_arg_ (&type, s); - type = ffecom_check_size_overflow_ (s, type, TRUE); + push_obstacks_nochange (); + end_temporary_allocation (); - for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) - { - if (type == error_mark_node) - break; + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; - dim = ffebld_head (dl); - assert (ffebld_op (dim) == FFEBLD_opBOUNDS); - if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_) - low = ffecom_integer_one_node; - else - low = ffecom_expr (ffebld_left (dim)); - assert (ffebld_right (dim) != NULL); - if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR) - || ffecom_doing_entry_) - { - /* Used to just do high=low. But for ffecom_tree_ - canonize_ref_, it probably is important to correctly - assess the size. E.g. given COMPLEX C(*),CFUNC and - C(2)=CFUNC(C), overlap can happen, while it can't - for, say, C(1)=CFUNC(C(2)). */ - /* Even more recently used to set to INT_MAX, but that - broke when some overflow checking went into the back - end. Now we just leave the upper bound unspecified. */ - high = NULL; - } - else - high = ffecom_expr (ffebld_right (dim)); + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); - /* Determine whether array is conditionally adjustable, - to decide whether back-end magic is needed. + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); - Normally the front end uses the back-end function - variable_size to wrap SAVE_EXPR's around expressions - affecting the size/shape of an array so that the - size/shape info doesn't change during execution - of the compiled code even though variables and - functions referenced in those expressions might. + resume_temporary_allocation (); + pop_obstacks (); - variable_size also makes sure those saved expressions - get evaluated immediately upon entry to the - compiled procedure -- the front end normally doesn't - have to worry about that. + break; - However, there is a problem with this that affects - g77's implementation of entry points, and that is - that it is _not_ true that each invocation of the - compiled procedure is permitted to evaluate - array size/shape info -- because it is possible - that, for some invocations, that info is invalid (in - which case it is "promised" -- i.e. a violation of - the Fortran standard -- that the compiled code - won't reference the array or its size/shape - during that particular invocation). + case FFEINFO_whereDUMMY: + assert (ffecom_transform_only_dummies_); - To phrase this in C terms, consider this gcc function: + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_ptr_to_subr_type); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; - void foo (int *n, float (*a)[*n]) - { - // a is "pointer to array ...", fyi. - } + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ - Suppose that, for some invocations, it is permitted - for a caller of foo to do this: + default: + assert ("SUBROUTINE where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - foo (NULL, NULL); + case FFEINFO_kindPROGRAM: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; - Now the _written_ code for foo can take such a call - into account by either testing explicitly for whether - (a == NULL) || (n == NULL) -- presumably it is - not permitted to reference *a in various fashions - if (n == NULL) I suppose -- or it can avoid it by - looking at other info (other arguments, static/global - data, etc.). + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("PROGRAM where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - However, this won't work in gcc 2.5.8 because it'll - automatically emit the code to save the "*n" - expression, which'll yield a NULL dereference for - the "foo (NULL, NULL)" call, something the code - for foo cannot prevent. + case FFEINFO_kindBLOCKDATA: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; - g77 definitely needs to avoid executing such - code anytime the pointer to the adjustable array - is NULL, because even if its bounds expressions - don't have any references to possible "absent" - variables like "*n" -- say all variable references - are to COMMON variables, i.e. global (though in C, - local static could actually make sense) -- the - expressions could yield other run-time problems - for allowably "dead" values in those variables. + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); - For example, let's consider a more complicated - version of foo: + push_obstacks_nochange (); + end_temporary_allocation (); - extern int i; - extern int j; + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_blockdata_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; - void foo (float (*a)[i/j]) - { - ... - } + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); - The above is (essentially) quite valid for Fortran - but, again, for a call like "foo (NULL);", it is - permitted for i and j to be undefined when the - call is made. If j happened to be zero, for - example, emitting the code to evaluate "i/j" - could result in a run-time error. + resume_temporary_allocation (); + pop_obstacks (); - Offhand, though I don't have my F77 or F90 - standards handy, it might even be valid for a - bounds expression to contain a function reference, - in which case I doubt it is permitted for an - implementation to invoke that function in the - Fortran case involved here (invocation of an - alternate ENTRY point that doesn't have the adjustable - array as one of its arguments). + break; - So, the code that the compiler would normally emit - to preevaluate the size/shape info for an - adjustable array _must not_ be executed at run time - in certain cases. Specifically, for Fortran, - the case is when the pointer to the adjustable - array == NULL. (For gnu-ish C, it might be nice - for the source code itself to specify an expression - that, if TRUE, inhibits execution of the code. Or - reverse the sense for elegance.) + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("BLOCKDATA where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - (Note that g77 could use a different test than NULL, - actually, since it happens to always pass an - integer to the called function that specifies which - entry point is being invoked. Hmm, this might - solve the next problem.) + case FFEINFO_kindCOMMON: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + ffecom_transform_common_ (s); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("COMMON where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - One way a user could, I suppose, write "foo" so - it works is to insert COND_EXPR's for the - size/shape info so the dangerous stuff isn't - actually done, as in: + case FFEINFO_kindCONSTRUCT: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + break; - void foo (int *n, float (*a)[(a == NULL) ? 0 : *n]) - { - ... - } + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("CONSTRUCT where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - The next problem is that the front end needs to - be able to tell the back end about the array's - decl _before_ it tells it about the conditional - expression to inhibit evaluation of size/shape info, - as shown above. + case FFEINFO_kindNAMELIST: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + t = ffecom_transform_namelist_ (s); + break; - To solve this, the front end needs to be able - to give the back end the expression to inhibit - generation of the preevaluation code _after_ - it makes the decl for the adjustable array. + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("NAMELIST where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; - Until then, the above example using the COND_EXPR - doesn't pass muster with gcc because the "(a == NULL)" - part has a reference to "a", which is still - undefined at that point. + default: + assert ("kind unheard of" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + t = error_mark_node; + break; + } - g77 will therefore use a different mechanism in the - meantime. */ + ffesymbol_hook (s).decl_tree = t; + ffesymbol_hook (s).length_tree = tlen; + ffesymbol_hook (s).addr = addr; - if (!adjustable - && ((TREE_CODE (low) != INTEGER_CST) - || (high && TREE_CODE (high) != INTEGER_CST))) - adjustable = TRUE; + lineno = old_lineno; + input_filename = old_input_filename; -#if 0 /* Old approach -- see below. */ - if (TREE_CODE (low) != INTEGER_CST) - low = ffecom_3 (COND_EXPR, integer_type_node, - ffecom_adjarray_passed_ (s), - low, - ffecom_integer_zero_node); + return s; +} - if (high && TREE_CODE (high) != INTEGER_CST) - high = ffecom_3 (COND_EXPR, integer_type_node, - ffecom_adjarray_passed_ (s), - high, - ffecom_integer_zero_node); #endif +/* Transform into ASSIGNable symbol. - /* ~~~gcc/stor-layout.c/layout_type should do this, - probably. Fixes 950302-1.f. */ - - if (TREE_CODE (low) != INTEGER_CST) - low = variable_size (low); - - /* ~~~similarly, this fixes dumb0.f. The C front end - does this, which is why dumb0.c would work. */ - - if (high && TREE_CODE (high) != INTEGER_CST) - high = variable_size (high); + Symbol has already been transformed, but for whatever reason, the + resulting decl_tree has been deemed not usable for an ASSIGN target. + (E.g. it isn't wide enough to hold a pointer.) So, here we invent + another local symbol of type void * and stuff that in the assign_tree + argument. The F77/F90 standards allow this implementation. */ - type - = build_array_type - (type, - build_range_type (ffecom_integer_type_node, - low, high)); - type = ffecom_check_size_overflow_ (s, type, TRUE); - } +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_sym_transform_assign_ (ffesymbol s) +{ + tree t; /* Transformed thingy. */ + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; - if (type == error_mark_node) - { - t = error_mark_node; - break; - } + if (ffesymbol_sfdummyparent (s) == NULL) + { + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); - if ((ffesymbol_sfdummyparent (s) == NULL) - || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) - { - type = build_pointer_type (type); - addr = TRUE; - } + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } - t = build_decl (PARM_DECL, t, type); -#if BUILT_FOR_270 - DECL_ARTIFICIAL (t) = 1; -#endif + assert (!ffecom_transform_only_dummies_); - /* If this arg is present in every entry point's list of - dummy args, then we're done. */ + yes = suspend_momentary (); - if (ffesymbol_numentries (s) - == (ffecom_num_entrypoints_ + 1)) - break; + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_ASSIGN_%s", + ffesymbol_text (s), + -1), + TREE_TYPE (null_pointer_node)); -#if 1 + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + /* Unlike for regular vars, SAVE status is easy to determine for + ASSIGNed vars, since there's no initialization, there's no + effective storage association (so "SAVE J" does not apply to + K even given "EQUIVALENCE (J,K)"), there's no size issue + to worry about, etc. */ + if ((ffesymbol_is_save (s) || ffe_is_saveall ()) + && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)) + TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */ + else + TREE_STATIC (t) = 0; /* No need to make static. */ + break; - /* If variable_size in stor-layout has been called during - the above, then get_pending_sizes should have the - yet-to-be-evaluated saved expressions pending. - Make the whole lot of them get emitted, conditionally - on whether the array decl ("t" above) is not NULL. */ + case FFEINFO_whereCOMMON: + TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */ + break; - { - tree sizes = get_pending_sizes (); - tree tem; + case FFEINFO_whereDUMMY: + /* Note that twinning a DUMMY means the caller won't see + the ASSIGNed value. But both F77 and F90 allow implementations + to do this, i.e. disallow Fortran code that would try and + take advantage of actually putting a label into a variable + via a dummy argument (or any other storage association, for + that matter). */ + TREE_STATIC (t) = 0; + break; - for (tem = sizes; - tem != old_sizes; - tem = TREE_CHAIN (tem)) - { - tree temv = TREE_VALUE (tem); + default: + TREE_STATIC (t) = 0; + break; + } - if (sizes == tem) - sizes = temv; - else - sizes - = ffecom_2 (COMPOUND_EXPR, - TREE_TYPE (sizes), - temv, - sizes); - } + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); - if (sizes != tem) - { - sizes - = ffecom_3 (COND_EXPR, - TREE_TYPE (sizes), - ffecom_2 (NE_EXPR, - integer_type_node, - t, - null_pointer_node), - sizes, - convert (TREE_TYPE (sizes), - integer_zero_node)); - sizes = ffecom_save_tree (sizes); + resume_momentary (yes); - sizes - = tree_cons (NULL_TREE, sizes, tem); - } + ffesymbol_hook (s).assign_tree = t; - if (sizes) - put_pending_sizes (sizes); - } + lineno = old_lineno; + input_filename = old_input_filename; -#else -#if 0 - if (adjustable - && (ffesymbol_numentries (s) - != ffecom_num_entrypoints_ + 1)) - DECL_SOMETHING (t) - = ffecom_2 (NE_EXPR, integer_type_node, - t, - null_pointer_node); -#else -#if 0 - if (adjustable - && (ffesymbol_numentries (s) - != ffecom_num_entrypoints_ + 1)) - { - ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED); - ffebad_here (0, ffesymbol_where_line (s), - ffesymbol_where_column (s)); - ffebad_string (ffesymbol_text (s)); - ffebad_finish (); - } -#endif -#endif -#endif - } - break; + return s; +} - case FFEINFO_whereCOMMON: - { - ffesymbol cs; - ffeglobal cg; - tree ct; - ffestorag st = ffesymbol_storage (s); - tree type; - int yes; +#endif +/* Implement COMMON area in back end. - cs = ffesymbol_common (s); /* The COMMON area itself. */ - if (st != NULL) /* Else not laid out. */ - { - ffecom_transform_common_ (cs); - st = ffesymbol_storage (s); - } + Because COMMON-based variables can be referenced in the dimension + expressions of dummy (adjustable) arrays, and because dummies + (in the gcc back end) need to be put in the outer binding level + of a function (which has two binding levels, the outer holding + the dummies and the inner holding the other vars), special care + must be taken to handle COMMON areas. - yes = suspend_momentary (); + The current strategy is basically to always tell the back end about + the COMMON area as a top-level external reference to just a block + of storage of the master type of that area (e.g. integer, real, + character, whatever -- not a structure). As a distinct action, + if initial values are provided, tell the back end about the area + as a top-level non-external (initialized) area and remember not to + allow further initialization or expansion of the area. Meanwhile, + if no initialization happens at all, tell the back end about + the largest size we've seen declared so the space does get reserved. + (This function doesn't handle all that stuff, but it does some + of the important things.) - type = ffecom_type_localvar_ (s, bt, kt); + Meanwhile, for COMMON variables themselves, just keep creating + references like *((float *) (&common_area + offset)) each time + we reference the variable. In other words, don't make a VAR_DECL + or any kind of component reference (like we used to do before 0.4), + though we might do that as well just for debugging purposes (and + stuff the rtl with the appropriate offset expression). */ - cg = ffesymbol_global (cs); /* The global COMMON info. */ - if ((cg == NULL) - || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON)) - ct = NULL_TREE; - else - ct = ffeglobal_hook (cg); /* The common area's tree. */ +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_transform_common_ (ffesymbol s) +{ + ffestorag st = ffesymbol_storage (s); + ffeglobal g = ffesymbol_global (s); + tree cbt; + tree cbtype; + tree init; + tree high; + bool is_init = ffestorag_is_init (st); - if ((ct == NULL_TREE) - || (st == NULL) - || (type == error_mark_node)) - t = error_mark_node; - else - { - ffetargetOffset offset; - ffestorag cst; + assert (st != NULL); - cst = ffestorag_parent (st); - assert (cst == ffesymbol_storage (cs)); + if ((g == NULL) + || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON)) + return; - offset = ffestorag_modulo (cst) - + ffestorag_offset (st) - - ffestorag_offset (cst); + /* First update the size of the area in global terms. */ - ffecom_debug_kludge_ (ct, "COMMON", s, type, offset); + ffeglobal_size_common (s, ffestorag_size (st)); - /* (t_type *) (((char *) &ct) + offset) */ + if (!ffeglobal_common_init (g)) + is_init = FALSE; /* No explicit init, don't let erroneous joins init. */ - t = convert (string_type_node, /* (char *) */ - ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (ct)), - ct)); - t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), - t, - build_int_2 (offset, 0)); - t = convert (build_pointer_type (type), - t); + cbt = ffeglobal_hook (g); - addr = TRUE; - } + /* If we already have declared this common block for a previous program + unit, and either we already initialized it or we don't have new + initialization for it, just return what we have without changing it. */ - resume_momentary (yes); - } - break; + if ((cbt != NULL_TREE) + && (!is_init + || !DECL_EXTERNAL (cbt))) + return; - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereGLOBAL: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("ENTITY where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + /* Process inits. */ - case FFEINFO_kindFUNCTION: - switch (ffeinfo_where (ffesymbol_info (s))) + if (is_init) + { + if (ffestorag_init (st) != NULL) { - case FFEINFO_whereLOCAL: /* Me. */ - assert (!ffecom_transform_only_dummies_); - t = current_function_decl; - break; - - case FFEINFO_whereGLOBAL: - assert (!ffecom_transform_only_dummies_); + ffebld sexp; - if (((g = ffesymbol_global (s)) != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) - && (ffeglobal_hook (g) != NULL_TREE) - && ffe_is_globals ()) + /* Set the padding for the expression, so ffecom_expr + knows to insert that many zeros. */ + switch (ffebld_op (sexp = ffestorag_init (st))) { - t = ffeglobal_hook (g); + case FFEBLD_opCONTER: + ffebld_conter_set_pad (sexp, ffestorag_modulo (st)); break; - } - push_obstacks_nochange (); - end_temporary_allocation (); + case FFEBLD_opARRTER: + ffebld_arrter_set_pad (sexp, ffestorag_modulo (st)); + break; - if (ffesymbol_is_f2c (s) - && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) - t = ffecom_tree_fun_type[bt][kt]; - else - t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + case FFEBLD_opACCTER: + ffebld_accter_set_pad (sexp, ffestorag_modulo (st)); + break; - t = build_decl (FUNCTION_DECL, - ffecom_get_external_identifier_ (s), - t); - DECL_EXTERNAL (t) = 1; - TREE_PUBLIC (t) = 1; + default: + assert ("bad op for cmn init (pad)" == NULL); + break; + } - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + init = ffecom_expr (sexp); + if (init == error_mark_node) + { /* Hopefully the back end complained! */ + init = NULL_TREE; + if (cbt != NULL_TREE) + return; + } + } + else + init = error_mark_node; + } + else + init = NULL_TREE; - if ((g != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) - ffeglobal_set_hook (g, t); + push_obstacks_nochange (); + end_temporary_allocation (); - resume_temporary_allocation (); - pop_obstacks (); + /* cbtype must be permanently allocated! */ - break; + /* Allocate the MAX of the areas so far, seen filewide. */ + high = build_int_2 ((ffeglobal_common_size (g) + + ffeglobal_common_pad (g)) - 1, 0); + TREE_TYPE (high) = ffecom_integer_type_node; - case FFEINFO_whereDUMMY: - assert (ffecom_transform_only_dummies_); + if (init) + cbtype = build_array_type (char_type_node, + build_range_type (integer_type_node, + integer_zero_node, + high)); + else + cbtype = build_array_type (char_type_node, NULL_TREE); - if (ffesymbol_is_f2c (s) - && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) - t = ffecom_tree_ptr_to_fun_type[bt][kt]; - else - t = build_pointer_type - (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE)); + if (cbt == NULL_TREE) + { + cbt + = build_decl (VAR_DECL, + ffecom_get_external_identifier_ (s), + cbtype); + TREE_STATIC (cbt) = 1; + TREE_PUBLIC (cbt) = 1; + } + else + { + assert (is_init); + TREE_TYPE (cbt) = cbtype; + } + DECL_EXTERNAL (cbt) = init ? 0 : 1; + DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE; - t = build_decl (PARM_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - t); -#if BUILT_FOR_270 - DECL_ARTIFICIAL (t) = 1; -#endif - addr = TRUE; - break; + cbt = start_decl (cbt, TRUE); + if (ffeglobal_hook (g) != NULL) + assert (cbt == ffeglobal_hook (g)); - case FFEINFO_whereCONSTANT: /* Statement function. */ - assert (!ffecom_transform_only_dummies_); - t = ffecom_gen_sfuncdef_ (s, bt, kt); - break; + assert (!init || !DECL_EXTERNAL (cbt)); - case FFEINFO_whereINTRINSIC: - assert (!ffecom_transform_only_dummies_); - break; /* Let actual references generate their - decls. */ + /* Make sure that any type can live in COMMON and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the COMMON, but + this seems easy enough. */ - default: - assert ("FUNCTION where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT; - case FFEINFO_kindSUBROUTINE: - switch (ffeinfo_where (ffesymbol_info (s))) - { - case FFEINFO_whereLOCAL: /* Me. */ - assert (!ffecom_transform_only_dummies_); - t = current_function_decl; - break; + if (is_init && (ffestorag_init (st) == NULL)) + init = ffecom_init_zero_ (cbt); - case FFEINFO_whereGLOBAL: - assert (!ffecom_transform_only_dummies_); + finish_decl (cbt, init, TRUE); - if (((g = ffesymbol_global (s)) != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) - && (ffeglobal_hook (g) != NULL_TREE) - && ffe_is_globals ()) - { - t = ffeglobal_hook (g); - break; - } + if (is_init) + ffestorag_set_init (st, ffebld_new_any ()); - push_obstacks_nochange (); - end_temporary_allocation (); + if (init) + { + tree size_tree; - t = build_decl (FUNCTION_DECL, - ffecom_get_external_identifier_ (s), - ffecom_tree_subr_type); - DECL_EXTERNAL (t) = 1; - TREE_PUBLIC (t) = 1; + assert (DECL_SIZE (cbt) != NULL_TREE); + assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST); + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (cbt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) + == ffeglobal_common_size (g) + ffeglobal_common_pad (g)); + } - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + ffeglobal_set_hook (g, cbt); - if ((g != NULL) - && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) - || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) - ffeglobal_set_hook (g, t); + ffestorag_set_hook (st, cbt); - resume_temporary_allocation (); - pop_obstacks (); + resume_temporary_allocation (); + pop_obstacks (); +} - break; +#endif +/* Make master area for local EQUIVALENCE. */ - case FFEINFO_whereDUMMY: - assert (ffecom_transform_only_dummies_); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_transform_equiv_ (ffestorag eqst) +{ + tree eqt; + tree eqtype; + tree init; + tree high; + bool is_init = ffestorag_is_init (eqst); + int yes; - t = build_decl (PARM_DECL, - ffecom_get_identifier_ (ffesymbol_text (s)), - ffecom_tree_ptr_to_subr_type); -#if BUILT_FOR_270 - DECL_ARTIFICIAL (t) = 1; -#endif - addr = TRUE; - break; + assert (eqst != NULL); - case FFEINFO_whereINTRINSIC: - assert (!ffecom_transform_only_dummies_); - break; /* Let actual references generate their - decls. */ + eqt = ffestorag_hook (eqst); - default: - assert ("SUBROUTINE where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + if (eqt != NULL_TREE) + return; - case FFEINFO_kindPROGRAM: - switch (ffeinfo_where (ffesymbol_info (s))) + /* Process inits. */ + + if (is_init) + { + if (ffestorag_init (eqst) != NULL) { - case FFEINFO_whereLOCAL: /* Me. */ - assert (!ffecom_transform_only_dummies_); - t = current_function_decl; - break; + ffebld sexp; - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereGLOBAL: - case FFEINFO_whereRESULT: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("PROGRAM where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + /* Set the padding for the expression, so ffecom_expr + knows to insert that many zeros. */ + switch (ffebld_op (sexp = ffestorag_init (eqst))) + { + case FFEBLD_opCONTER: + ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst)); + break; - case FFEINFO_kindBLOCKDATA: - switch (ffeinfo_where (ffesymbol_info (s))) - { - case FFEINFO_whereLOCAL: /* Me. */ - assert (!ffecom_transform_only_dummies_); - t = current_function_decl; - break; + case FFEBLD_opARRTER: + ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst)); + break; - case FFEINFO_whereGLOBAL: - assert (!ffecom_transform_only_dummies_); + case FFEBLD_opACCTER: + ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst)); + break; - push_obstacks_nochange (); - end_temporary_allocation (); + default: + assert ("bad op for eqv init (pad)" == NULL); + break; + } - t = build_decl (FUNCTION_DECL, - ffecom_get_external_identifier_ (s), - ffecom_tree_blockdata_type); - DECL_EXTERNAL (t) = 1; - TREE_PUBLIC (t) = 1; + init = ffecom_expr (sexp); + if (init == error_mark_node) + init = NULL_TREE; /* Hopefully the back end complained! */ + } + else + init = error_mark_node; + } + else if (ffe_is_init_local_zero ()) + init = error_mark_node; + else + init = NULL_TREE; - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + ffecom_member_namelisted_ = FALSE; + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase1_, + eqst); - resume_temporary_allocation (); - pop_obstacks (); + yes = suspend_momentary (); - break; + high = build_int_2 ((ffestorag_size (eqst) + + ffestorag_modulo (eqst)) - 1, 0); + TREE_TYPE (high) = ffecom_integer_type_node; - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereRESULT: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("BLOCKDATA where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + eqtype = build_array_type (char_type_node, + build_range_type (ffecom_integer_type_node, + ffecom_integer_zero_node, + high)); + + eqt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_equiv_%s", + ffesymbol_text + (ffestorag_symbol + (eqst)), + -1), + eqtype); + DECL_EXTERNAL (eqt) = 0; + if (is_init + || ffecom_member_namelisted_ +#ifdef FFECOM_sizeMAXSTACKITEM + || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + && (ffestorag_is_save (eqst) || ffe_is_saveall ()))) + TREE_STATIC (eqt) = 1; + else + TREE_STATIC (eqt) = 0; + TREE_PUBLIC (eqt) = 0; + DECL_CONTEXT (eqt) = current_function_decl; + if (init) + DECL_INITIAL (eqt) = error_mark_node; + else + DECL_INITIAL (eqt) = NULL_TREE; - case FFEINFO_kindCOMMON: - switch (ffeinfo_where (ffesymbol_info (s))) - { - case FFEINFO_whereLOCAL: - assert (!ffecom_transform_only_dummies_); - ffecom_transform_common_ (s); - break; + eqt = start_decl (eqt, FALSE); - case FFEINFO_whereNONE: - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereGLOBAL: - case FFEINFO_whereRESULT: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("COMMON where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + /* Make sure that any type can live in EQUIVALENCE and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the EQUIVALENCE, but + this seems easy enough. */ - case FFEINFO_kindCONSTRUCT: - switch (ffeinfo_where (ffesymbol_info (s))) - { - case FFEINFO_whereLOCAL: - assert (!ffecom_transform_only_dummies_); - break; + DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT; - case FFEINFO_whereNONE: - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereGLOBAL: - case FFEINFO_whereRESULT: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("CONSTRUCT where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + if ((!is_init && ffe_is_init_local_zero ()) + || (is_init && (ffestorag_init (eqst) == NULL))) + init = ffecom_init_zero_ (eqt); - case FFEINFO_kindNAMELIST: - switch (ffeinfo_where (ffesymbol_info (s))) - { - case FFEINFO_whereLOCAL: - assert (!ffecom_transform_only_dummies_); - t = ffecom_transform_namelist_ (s); - break; + finish_decl (eqt, init, FALSE); - case FFEINFO_whereNONE: - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereGLOBAL: - case FFEINFO_whereRESULT: - case FFEINFO_whereFLEETING: - case FFEINFO_whereFLEETING_CADDR: - case FFEINFO_whereFLEETING_IADDR: - case FFEINFO_whereIMMEDIATE: - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereCONSTANT: - case FFEINFO_whereCONSTANT_SUBOBJECT: - default: - assert ("NAMELIST where unheard of" == NULL); - /* Fall through. */ - case FFEINFO_whereANY: - t = error_mark_node; - break; - } - break; + if (is_init) + ffestorag_set_init (eqst, ffebld_new_any ()); - default: - assert ("kind unheard of" == NULL); - /* Fall through. */ - case FFEINFO_kindANY: - t = error_mark_node; - break; - } + { + tree size_tree; - ffesymbol_hook (s).decl_tree = t; - ffesymbol_hook (s).length_tree = tlen; - ffesymbol_hook (s).addr = addr; + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (eqt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) + == ffestorag_size (eqst) + ffestorag_modulo (eqst)); + } - lineno = old_lineno; - input_filename = old_input_filename; + ffestorag_set_hook (eqst, eqt); - return s; +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase2_, + eqst); +#endif + + resume_momentary (yes); } #endif -/* Transform into ASSIGNable symbol. - - Symbol has already been transformed, but for whatever reason, the - resulting decl_tree has been deemed not usable for an ASSIGN target. - (E.g. it isn't wide enough to hold a pointer.) So, here we invent - another local symbol of type void * and stuff that in the assign_tree - argument. The F77/F90 standards allow this implementation. */ +/* Implement NAMELIST in back end. See f2c/format.c for more info. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static ffesymbol -ffecom_sym_transform_assign_ (ffesymbol s) +static tree +ffecom_transform_namelist_ (ffesymbol s) { - tree t; /* Transformed thingy. */ + tree nmlt; + tree nmltype = ffecom_type_namelist_ (); + tree nmlinits; + tree nameinit; + tree varsinit; + tree nvarsinit; + tree field; + tree high; int yes; - int old_lineno = lineno; - char *old_input_filename = input_filename; + int i; + static int mynumber = 0; - if (ffesymbol_sfdummyparent (s) == NULL) - { - input_filename = ffesymbol_where_filename (s); - lineno = ffesymbol_where_filelinenum (s); - } - else - { - ffesymbol sf = ffesymbol_sfdummyparent (s); + yes = suspend_momentary (); - input_filename = ffesymbol_where_filename (sf); - lineno = ffesymbol_where_filelinenum (sf); - } + nmlt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_namelist_%d", + NULL, mynumber++), + nmltype); + TREE_STATIC (nmlt) = 1; + DECL_INITIAL (nmlt) = error_mark_node; - assert (!ffecom_transform_only_dummies_); + nmlt = start_decl (nmlt, FALSE); - yes = suspend_momentary (); + /* Process inits. */ - t = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_ASSIGN_%s", - ffesymbol_text (s), - 0), - TREE_TYPE (null_pointer_node)); + i = strlen (ffesymbol_text (s)); - switch (ffesymbol_where (s)) - { - case FFEINFO_whereLOCAL: - /* Unlike for regular vars, SAVE status is easy to determine for - ASSIGNed vars, since there's no initialization, there's no - effective storage association (so "SAVE J" does not apply to - K even given "EQUIVALENCE (J,K)"), there's no size issue - to worry about, etc. */ - if ((ffesymbol_is_save (s) || ffe_is_saveall ()) - && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) - && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)) - TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */ - else - TREE_STATIC (t) = 0; /* No need to make static. */ + high = build_int_2 (i, 0); + TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + + nameinit = ffecom_build_f2c_string_ (i + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + high)), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)), + nameinit); + + varsinit = ffecom_vardesc_array_ (s); + varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)), + varsinit); + TREE_CONSTANT (varsinit) = 1; + TREE_STATIC (varsinit) = 1; + + { + ffebld b; + + for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b)) + ++i; + } + nvarsinit = build_int_2 (i, 0); + TREE_TYPE (nvarsinit) = integer_type_node; + TREE_CONSTANT (nvarsinit) = 1; + TREE_STATIC (nvarsinit) = 1; + + nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit); + TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)), + varsinit); + TREE_CHAIN (TREE_CHAIN (nmlinits)) + = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit); + + nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits); + TREE_CONSTANT (nmlinits) = 1; + TREE_STATIC (nmlinits) = 1; + + finish_decl (nmlt, nmlinits, FALSE); + + nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); + + resume_momentary (yes); + + return nmlt; +} + +#endif + +/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is + analyzed on the assumption it is calculating a pointer to be + indirected through. It must return the proper decl and offset, + taking into account different units of measurements for offsets. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, + tree t) +{ + switch (TREE_CODE (t)) + { + case NOP_EXPR: + case CONVERT_EXPR: + case NON_LVALUE_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); break; - case FFEINFO_whereCOMMON: - TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */ + case PLUS_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + break; + + if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST) + { + /* An offset into COMMON. */ + *offset = size_binop (PLUS_EXPR, + *offset, + TREE_OPERAND (t, 1)); + /* Convert offset (presumably in bytes) into canonical units + (presumably bits). */ + *offset = size_binop (MULT_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))), + *offset); + break; + } + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; break; - case FFEINFO_whereDUMMY: - /* Note that twinning a DUMMY means the caller won't see - the ASSIGNed value. But both F77 and F90 allow implementations - to do this, i.e. disallow Fortran code that would try and - take advantage of actually putting a label into a variable - via a dummy argument (or any other storage association, for - that matter). */ - TREE_STATIC (t) = 0; + case PARM_DECL: + *decl = t; + *offset = bitsize_int (0L, 0L); break; + case ADDR_EXPR: + if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL) + { + /* A reference to COMMON. */ + *decl = TREE_OPERAND (t, 0); + *offset = bitsize_int (0L, 0L); + break; + } + /* Fall through. */ default: - TREE_STATIC (t) = 0; + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; break; } +} +#endif - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); - - resume_momentary (yes); - - ffesymbol_hook (s).assign_tree = t; +/* Given a tree that is possibly intended for use as an lvalue, return + information representing a canonical view of that tree as a decl, an + offset into that decl, and a size for the lvalue. - lineno = old_lineno; - input_filename = old_input_filename; + If there's no applicable decl, NULL_TREE is returned for the decl, + and the other fields are left undefined. - return s; -} + If the tree doesn't fit the recognizable forms, an ERROR_MARK node + is returned for the decl, and the other fields are left undefined. -#endif -/* Implement COMMON area in back end. + Otherwise, the decl returned currently is either a VAR_DECL or a + PARM_DECL. - Because COMMON-based variables can be referenced in the dimension - expressions of dummy (adjustable) arrays, and because dummies - (in the gcc back end) need to be put in the outer binding level - of a function (which has two binding levels, the outer holding - the dummies and the inner holding the other vars), special care - must be taken to handle COMMON areas. + The offset returned is always valid, but of course not necessarily + a constant, and not necessarily converted into the appropriate + type, leaving that up to the caller (so as to avoid that overhead + if the decls being looked at are different anyway). - The current strategy is basically to always tell the back end about - the COMMON area as a top-level external reference to just a block - of storage of the master type of that area (e.g. integer, real, - character, whatever -- not a structure). As a distinct action, - if initial values are provided, tell the back end about the area - as a top-level non-external (initialized) area and remember not to - allow further initialization or expansion of the area. Meanwhile, - if no initialization happens at all, tell the back end about - the largest size we've seen declared so the space does get reserved. - (This function doesn't handle all that stuff, but it does some - of the important things.) + If the size cannot be determined (e.g. an adjustable array), + an ERROR_MARK node is returned for the size. Otherwise, the + size returned is valid, not necessarily a constant, and not + necessarily converted into the appropriate type as with the + offset. - Meanwhile, for COMMON variables themselves, just keep creating - references like *((float *) (&common_area + offset)) each time - we reference the variable. In other words, don't make a VAR_DECL - or any kind of component reference (like we used to do before 0.4), - though we might do that as well just for debugging purposes (and - stuff the rtl with the appropriate offset expression). */ + Note that the offset and size expressions are expressed in the + base storage units (usually bits) rather than in the units of + the type of the decl, because two decls with different types + might overlap but with apparently non-overlapping array offsets, + whereas converting the array offsets to consistant offsets will + reveal the overlap. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static void -ffecom_transform_common_ (ffesymbol s) +ffecom_tree_canonize_ref_ (tree *decl, tree *offset, + tree *size, tree t) { - ffestorag st = ffesymbol_storage (s); - ffeglobal g = ffesymbol_global (s); - tree cbt; - tree cbtype; - tree init; - tree high; - bool is_init = ffestorag_is_init (st); - - assert (st != NULL); + /* The default path is to report a nonexistant decl. */ + *decl = NULL_TREE; - if ((g == NULL) - || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON)) + if (t == NULL_TREE) return; - /* First update the size of the area in global terms. */ + switch (TREE_CODE (t)) + { + case ERROR_MARK: + case IDENTIFIER_NODE: + case INTEGER_CST: + case REAL_CST: + case COMPLEX_CST: + case STRING_CST: + case CONST_DECL: + case PLUS_EXPR: + case MINUS_EXPR: + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case ROUND_DIV_EXPR: + case TRUNC_MOD_EXPR: + case CEIL_MOD_EXPR: + case FLOOR_MOD_EXPR: + case ROUND_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case FIX_TRUNC_EXPR: + case FIX_CEIL_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FLOAT_EXPR: + case EXPON_EXPR: + case NEGATE_EXPR: + case MIN_EXPR: + case MAX_EXPR: + case ABS_EXPR: + case FFS_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_ANDTC_EXPR: + case BIT_NOT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + case LABEL_EXPR: + case COMPONENT_REF: + case COMPOUND_EXPR: + case ADDR_EXPR: + return; - ffeglobal_size_common (s, ffestorag_size (st)); + case VAR_DECL: + case PARM_DECL: + *decl = t; + *offset = bitsize_int (0L, 0L); + *size = TYPE_SIZE (TREE_TYPE (t)); + return; - if (!ffeglobal_common_init (g)) - is_init = FALSE; /* No explicit init, don't let erroneous joins init. */ + case ARRAY_REF: + { + tree array = TREE_OPERAND (t, 0); + tree element = TREE_OPERAND (t, 1); + tree init_offset; + + if ((array == NULL_TREE) + || (element == NULL_TREE)) + { + *decl = error_mark_node; + return; + } + + ffecom_tree_canonize_ref_ (decl, &init_offset, size, + array); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + return; + + *offset = size_binop (MULT_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))), + size_binop (MINUS_EXPR, + element, + TYPE_MIN_VALUE + (TYPE_DOMAIN + (TREE_TYPE (array))))); + + *offset = size_binop (PLUS_EXPR, + init_offset, + *offset); + + *size = TYPE_SIZE (TREE_TYPE (t)); + return; + } + + case INDIRECT_REF: + + /* Most of this code is to handle references to COMMON. And so + far that is useful only for calling library functions, since + external (user) functions might reference common areas. But + even calling an external function, it's worthwhile to decode + COMMON references because if not storing into COMMON, we don't + want COMMON-based arguments to gratuitously force use of a + temporary. */ + + *size = TYPE_SIZE (TREE_TYPE (t)); - cbt = ffeglobal_hook (g); + ffecom_tree_canonize_ptr_ (decl, offset, + TREE_OPERAND (t, 0)); - /* If we already have declared this common block for a previous program - unit, and either we already initialized it or we don't have new - initialization for it, just return what we have without changing it. */ + return; - if ((cbt != NULL_TREE) - && (!is_init - || !DECL_EXTERNAL (cbt))) - return; + case CONVERT_EXPR: + case NOP_EXPR: + case MODIFY_EXPR: + case NON_LVALUE_EXPR: + case RESULT_DECL: + case FIELD_DECL: + case COND_EXPR: /* More cases than we can handle. */ + case SAVE_EXPR: + case REFERENCE_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case CALL_EXPR: + default: + *decl = error_mark_node; + return; + } +} +#endif - /* Process inits. */ +/* Do divide operation appropriate to type of operands. */ - if (is_init) - { - if (ffestorag_init (st) != NULL) - { - ffebld sexp; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_tree_divide_ (tree tree_type, tree left, tree right, + tree dest_tree, ffebld dest, bool *dest_used, + tree hook) +{ + if ((left == error_mark_node) + || (right == error_mark_node)) + return error_mark_node; - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (st))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (st)); - break; + switch (TREE_CODE (tree_type)) + { + case INTEGER_TYPE: + return ffecom_2 (TRUNC_DIV_EXPR, tree_type, + left, + right); - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (st)); - break; + case COMPLEX_TYPE: + { + ffecomGfrt ix; - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (st)); - break; + if (TREE_TYPE (tree_type) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ - default: - assert ("bad op for cmn init (pad)" == NULL); - break; - } + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; - init = ffecom_expr (sexp); - if (init == error_mark_node) - { /* Hopefully the back end complained! */ - init = NULL_TREE; - if (cbt != NULL_TREE) - return; - } - } - else - init = error_mark_node; - } - else - init = NULL_TREE; + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE, hook); + } + break; - push_obstacks_nochange (); - end_temporary_allocation (); + case RECORD_TYPE: + { + ffecomGfrt ix; - /* cbtype must be permanently allocated! */ + if (TREE_TYPE (TYPE_FIELDS (tree_type)) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ - /* Allocate the MAX of the areas so far, seen filewide. */ - high = build_int_2 ((ffeglobal_common_size (g) - + ffeglobal_common_pad (g)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; - if (init) - cbtype = build_array_type (char_type_node, - build_range_type (integer_type_node, - integer_zero_node, - high)); - else - cbtype = build_array_type (char_type_node, NULL_TREE); + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE, hook); + } + break; - if (cbt == NULL_TREE) - { - cbt - = build_decl (VAR_DECL, - ffecom_get_external_identifier_ (s), - cbtype); - TREE_STATIC (cbt) = 1; - TREE_PUBLIC (cbt) = 1; - } - else - { - assert (is_init); - TREE_TYPE (cbt) = cbtype; + default: + return ffecom_2 (RDIV_EXPR, tree_type, + left, + right); } - DECL_EXTERNAL (cbt) = init ? 0 : 1; - DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE; +} - cbt = start_decl (cbt, TRUE); - if (ffeglobal_hook (g) != NULL) - assert (cbt == ffeglobal_hook (g)); +#endif +/* Build type info for non-dummy variable. */ - assert (!init || !DECL_EXTERNAL (cbt)); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, + ffeinfoKindtype kt) +{ + tree type; + ffebld dl; + ffebld dim; + tree lowt; + tree hight; - /* Make sure that any type can live in COMMON and be referenced - without getting a bus error. We could pick the most restrictive - alignment of all entities actually placed in the COMMON, but - this seems easy enough. */ + type = ffecom_tree_type[bt][kt]; + if (bt == FFEINFO_basictypeCHARACTER) + { + hight = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node; - DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT; + type + = build_array_type + (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } - if (is_init && (ffestorag_init (st) == NULL)) - init = ffecom_init_zero_ (cbt); + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; - finish_decl (cbt, init, TRUE); + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); - if (is_init) - ffestorag_set_init (st, ffebld_new_any ()); + if (ffebld_left (dim) == NULL) + lowt = integer_one_node; + else + lowt = ffecom_expr (ffebld_left (dim)); - if (init) - { - tree size_tree; + if (TREE_CODE (lowt) != INTEGER_CST) + lowt = variable_size (lowt); - assert (DECL_SIZE (cbt) != NULL_TREE); - assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST); - size_tree = size_binop (CEIL_DIV_EXPR, - DECL_SIZE (cbt), - size_int (BITS_PER_UNIT)); - assert (TREE_INT_CST_HIGH (size_tree) == 0); - assert (TREE_INT_CST_LOW (size_tree) - == ffeglobal_common_size (g) + ffeglobal_common_pad (g)); - } + assert (ffebld_right (dim) != NULL); + hight = ffecom_expr (ffebld_right (dim)); - ffeglobal_set_hook (g, cbt); + if (TREE_CODE (hight) != INTEGER_CST) + hight = variable_size (hight); - ffestorag_set_hook (st, cbt); + type = build_array_type (type, + build_range_type (ffecom_integer_type_node, + lowt, hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } - resume_temporary_allocation (); - pop_obstacks (); + return type; } #endif -/* Make master area for local EQUIVALENCE. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_transform_equiv_ (ffestorag eqst) -{ - tree eqt; - tree eqtype; - tree init; - tree high; - bool is_init = ffestorag_is_init (eqst); - int yes; - - assert (eqst != NULL); +/* Build Namelist type. */ - eqt = ffestorag_hook (eqst); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_namelist_ () +{ + static tree type = NULL_TREE; - if (eqt != NULL_TREE) - return; + if (type == NULL_TREE) + { + static tree namefield, varsfield, nvarsfield; + tree vardesctype; - /* Process inits. */ + vardesctype = ffecom_type_vardesc_ (); - if (is_init) - { - if (ffestorag_init (eqst) != NULL) - { - ffebld sexp; + push_obstacks_nochange (); + end_temporary_allocation (); - /* Set the padding for the expression, so ffecom_expr - knows to insert that many zeros. */ - switch (ffebld_op (sexp = ffestorag_init (eqst))) - { - case FFEBLD_opCONTER: - ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst)); - break; + type = make_node (RECORD_TYPE); - case FFEBLD_opARRTER: - ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst)); - break; + vardesctype = build_pointer_type (build_pointer_type (vardesctype)); - case FFEBLD_opACCTER: - ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst)); - break; + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype); + nvarsfield = ffecom_decl_field (type, varsfield, "nvars", + integer_type_node); - default: - assert ("bad op for eqv init (pad)" == NULL); - break; - } + TYPE_FIELDS (type) = namefield; + layout_type (type); - init = ffecom_expr (sexp); - if (init == error_mark_node) - init = NULL_TREE; /* Hopefully the back end complained! */ - } - else - init = error_mark_node; + resume_temporary_allocation (); + pop_obstacks (); } - else if (ffe_is_init_local_zero ()) - init = error_mark_node; - else - init = NULL_TREE; - ffecom_member_namelisted_ = FALSE; - ffestorag_drive (ffestorag_list_equivs (eqst), - &ffecom_member_phase1_, - eqst); + return type; +} - yes = suspend_momentary (); +#endif - high = build_int_2 ((ffestorag_size (eqst) - + ffestorag_modulo (eqst)) - 1, 0); - TREE_TYPE (high) = ffecom_integer_type_node; +/* Make a copy of a type, assuming caller has switched to the permanent + obstacks and that the type is for an aggregate (array) initializer. */ - eqtype = build_array_type (char_type_node, - build_range_type (ffecom_integer_type_node, - ffecom_integer_zero_node, - high)); +#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */ +static tree +ffecom_type_permanent_copy_ (tree t) +{ + tree domain; + tree max; - eqt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_equiv_%s", - ffesymbol_text - (ffestorag_symbol - (eqst)), - 0), - eqtype); - DECL_EXTERNAL (eqt) = 0; - if (is_init - || ffecom_member_namelisted_ -#ifdef FFECOM_sizeMAXSTACKITEM - || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM) -#endif - || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) - && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) - && (ffestorag_is_save (eqst) || ffe_is_saveall ()))) - TREE_STATIC (eqt) = 1; - else - TREE_STATIC (eqt) = 0; - TREE_PUBLIC (eqt) = 0; - DECL_CONTEXT (eqt) = current_function_decl; - if (init) - DECL_INITIAL (eqt) = error_mark_node; - else - DECL_INITIAL (eqt) = NULL_TREE; + assert (TREE_TYPE (t) != NULL_TREE); - eqt = start_decl (eqt, FALSE); + domain = TYPE_DOMAIN (t); - /* Make sure that any type can live in EQUIVALENCE and be referenced - without getting a bus error. We could pick the most restrictive - alignment of all entities actually placed in the EQUIVALENCE, but - this seems easy enough. */ + assert (TREE_CODE (t) == ARRAY_TYPE); + assert (TREE_PERMANENT (TREE_TYPE (t))); + assert (TREE_PERMANENT (TREE_TYPE (domain))); + assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain))); - DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT; + max = TYPE_MAX_VALUE (domain); + if (!TREE_PERMANENT (max)) + { + assert (TREE_CODE (max) == INTEGER_CST); - if ((!is_init && ffe_is_init_local_zero ()) - || (is_init && (ffestorag_init (eqst) == NULL))) - init = ffecom_init_zero_ (eqt); + max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max)); + TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain)); + } - finish_decl (eqt, init, FALSE); + return build_array_type (TREE_TYPE (t), + build_range_type (TREE_TYPE (domain), + TYPE_MIN_VALUE (domain), + max)); +} +#endif - if (is_init) - ffestorag_set_init (eqst, ffebld_new_any ()); +/* Build Vardesc type. */ - { - tree size_tree; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_vardesc_ () +{ + static tree type = NULL_TREE; + static tree namefield, addrfield, dimsfield, typefield; - size_tree = size_binop (CEIL_DIV_EXPR, - DECL_SIZE (eqt), - size_int (BITS_PER_UNIT)); - assert (TREE_INT_CST_HIGH (size_tree) == 0); - assert (TREE_INT_CST_LOW (size_tree) - == ffestorag_size (eqst) + ffestorag_modulo (eqst)); - } + if (type == NULL_TREE) + { + push_obstacks_nochange (); + end_temporary_allocation (); - ffestorag_set_hook (eqst, eqt); + type = make_node (RECORD_TYPE); -#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING - ffestorag_drive (ffestorag_list_equivs (eqst), - &ffecom_member_phase2_, - eqst); -#endif + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + addrfield = ffecom_decl_field (type, namefield, "addr", + string_type_node); + dimsfield = ffecom_decl_field (type, addrfield, "dims", + ffecom_f2c_ptr_to_ftnlen_type_node); + typefield = ffecom_decl_field (type, dimsfield, "type", + integer_type_node); - resume_momentary (yes); + TYPE_FIELDS (type) = namefield; + layout_type (type); + + resume_temporary_allocation (); + pop_obstacks (); + } + + return type; } #endif -/* Implement NAMELIST in back end. See f2c/format.c for more info. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static tree -ffecom_transform_namelist_ (ffesymbol s) +ffecom_vardesc_ (ffebld expr) { - tree nmlt; - tree nmltype = ffecom_type_namelist_ (); - tree nmlinits; - tree nameinit; - tree varsinit; - tree nvarsinit; - tree field; - tree high; - int yes; - int i; - static int mynumber = 0; + ffesymbol s; - yes = suspend_momentary (); + assert (ffebld_op (expr) == FFEBLD_opSYMTER); + s = ffebld_symter (expr); - nmlt = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_namelist_%d", - NULL, mynumber++), - nmltype); - TREE_STATIC (nmlt) = 1; - DECL_INITIAL (nmlt) = error_mark_node; + if (ffesymbol_hook (s).vardesc_tree == NULL_TREE) + { + int i; + tree vardesctype = ffecom_type_vardesc_ (); + tree var; + tree nameinit; + tree dimsinit; + tree addrinit; + tree typeinit; + tree field; + tree varinits; + int yes; + static int mynumber = 0; - nmlt = start_decl (nmlt, FALSE); + yes = suspend_momentary (); - /* Process inits. */ + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_vardesc_%d", + NULL, mynumber++), + vardesctype); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; - i = strlen (ffesymbol_text (s)); + var = start_decl (var, FALSE); - high = build_int_2 (i, 0); - TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + /* Process inits. */ - nameinit = ffecom_build_f2c_string_ (i + 1, - ffesymbol_text (s)); - TREE_TYPE (nameinit) - = build_type_variant - (build_array_type - (char_type_node, - build_range_type (ffecom_f2c_ftnlen_type_node, - ffecom_f2c_ftnlen_one_node, - high)), - 1, 0); - TREE_CONSTANT (nameinit) = 1; - TREE_STATIC (nameinit) = 1; - nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)), - nameinit); + nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) + + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (nameinit)), + nameinit); - varsinit = ffecom_vardesc_array_ (s); - varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)), - varsinit); - TREE_CONSTANT (varsinit) = 1; - TREE_STATIC (varsinit) = 1; + addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit); - { - ffebld b; + dimsinit = ffecom_vardesc_dims_ (s); - for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b)) - ++i; - } - nvarsinit = build_int_2 (i, 0); - TREE_TYPE (nvarsinit) = integer_type_node; - TREE_CONSTANT (nvarsinit) = 1; - TREE_STATIC (nvarsinit) = 1; + if (typeinit == NULL_TREE) + { + ffeinfoBasictype bt = ffesymbol_basictype (s); + ffeinfoKindtype kt = ffesymbol_kindtype (s); + int tc = ffecom_f2c_typecode (bt, kt); - nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit); - TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)), - varsinit); - TREE_CHAIN (TREE_CHAIN (nmlinits)) - = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit); + assert (tc != -1); + typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0); + } + else + typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit); - nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits); - TREE_CONSTANT (nmlinits) = 1; - TREE_STATIC (nmlinits) = 1; + varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)), + nameinit); + TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)), + addrinit); + TREE_CHAIN (TREE_CHAIN (varinits)) + = build_tree_list ((field = TREE_CHAIN (field)), dimsinit); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits))) + = build_tree_list ((field = TREE_CHAIN (field)), typeinit); - finish_decl (nmlt, nmlinits, FALSE); + varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits); + TREE_CONSTANT (varinits) = 1; + TREE_STATIC (varinits) = 1; - nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); + finish_decl (var, varinits, FALSE); - resume_momentary (yes); + var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); - return nmlt; -} + resume_momentary (yes); -#endif + ffesymbol_hook (s).vardesc_tree = var; + } -/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is - analyzed on the assumption it is calculating a pointer to be - indirected through. It must return the proper decl and offset, - taking into account different units of measurements for offsets. */ + return ffesymbol_hook (s).vardesc_tree; +} +#endif #if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, - tree t) +static tree +ffecom_vardesc_array_ (ffesymbol s) { - switch (TREE_CODE (t)) - { - case NOP_EXPR: - case CONVERT_EXPR: - case NON_LVALUE_EXPR: - ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); - break; - - case PLUS_EXPR: - ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); - if ((*decl == NULL_TREE) - || (*decl == error_mark_node)) - break; + ffebld b; + tree list; + tree item = NULL_TREE; + tree var; + int i; + int yes; + static int mynumber = 0; - if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST) - { - /* An offset into COMMON. */ - *offset = size_binop (PLUS_EXPR, - *offset, - TREE_OPERAND (t, 1)); - /* Convert offset (presumably in bytes) into canonical units - (presumably bits). */ - *offset = size_binop (MULT_EXPR, - TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))), - *offset); - break; - } - /* Not a COMMON reference, so an unrecognized pattern. */ - *decl = error_mark_node; - break; + for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s); + b != NULL; + b = ffebld_trail (b), ++i) + { + tree t; - case PARM_DECL: - *decl = t; - *offset = bitsize_int (0L, 0L); - break; + t = ffecom_vardesc_ (ffebld_head (b)); - case ADDR_EXPR: - if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL) + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else { - /* A reference to COMMON. */ - *decl = TREE_OPERAND (t, 0); - *offset = bitsize_int (0L, 0L); - break; + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); } - /* Fall through. */ - default: - /* Not a COMMON reference, so an unrecognized pattern. */ - *decl = error_mark_node; - break; } -} -#endif - -/* Given a tree that is possibly intended for use as an lvalue, return - information representing a canonical view of that tree as a decl, an - offset into that decl, and a size for the lvalue. - - If there's no applicable decl, NULL_TREE is returned for the decl, - and the other fields are left undefined. - - If the tree doesn't fit the recognizable forms, an ERROR_MARK node - is returned for the decl, and the other fields are left undefined. - - Otherwise, the decl returned currently is either a VAR_DECL or a - PARM_DECL. - - The offset returned is always valid, but of course not necessarily - a constant, and not necessarily converted into the appropriate - type, leaving that up to the caller (so as to avoid that overhead - if the decls being looked at are different anyway). - If the size cannot be determined (e.g. an adjustable array), - an ERROR_MARK node is returned for the size. Otherwise, the - size returned is valid, not necessarily a constant, and not - necessarily converted into the appropriate type as with the - offset. + yes = suspend_momentary (); - Note that the offset and size expressions are expressed in the - base storage units (usually bits) rather than in the units of - the type of the decl, because two decls with different types - might overlap but with apparently non-overlapping array offsets, - whereas converting the array offsets to consistant offsets will - reveal the overlap. */ + item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()), + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffecom_tree_canonize_ref_ (tree *decl, tree *offset, - tree *size, tree t) -{ - /* The default path is to report a nonexistant decl. */ - *decl = NULL_TREE; + var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); - if (t == NULL_TREE) - return; + resume_momentary (yes); - switch (TREE_CODE (t)) - { - case ERROR_MARK: - case IDENTIFIER_NODE: - case INTEGER_CST: - case REAL_CST: - case COMPLEX_CST: - case STRING_CST: - case CONST_DECL: - case PLUS_EXPR: - case MINUS_EXPR: - case MULT_EXPR: - case TRUNC_DIV_EXPR: - case CEIL_DIV_EXPR: - case FLOOR_DIV_EXPR: - case ROUND_DIV_EXPR: - case TRUNC_MOD_EXPR: - case CEIL_MOD_EXPR: - case FLOOR_MOD_EXPR: - case ROUND_MOD_EXPR: - case RDIV_EXPR: - case EXACT_DIV_EXPR: - case FIX_TRUNC_EXPR: - case FIX_CEIL_EXPR: - case FIX_FLOOR_EXPR: - case FIX_ROUND_EXPR: - case FLOAT_EXPR: - case EXPON_EXPR: - case NEGATE_EXPR: - case MIN_EXPR: - case MAX_EXPR: - case ABS_EXPR: - case FFS_EXPR: - case LSHIFT_EXPR: - case RSHIFT_EXPR: - case LROTATE_EXPR: - case RROTATE_EXPR: - case BIT_IOR_EXPR: - case BIT_XOR_EXPR: - case BIT_AND_EXPR: - case BIT_ANDTC_EXPR: - case BIT_NOT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - case TRUTH_NOT_EXPR: - case LT_EXPR: - case LE_EXPR: - case GT_EXPR: - case GE_EXPR: - case EQ_EXPR: - case NE_EXPR: - case COMPLEX_EXPR: - case CONJ_EXPR: - case REALPART_EXPR: - case IMAGPART_EXPR: - case LABEL_EXPR: - case COMPONENT_REF: - case COMPOUND_EXPR: - case ADDR_EXPR: - return; + return var; +} - case VAR_DECL: - case PARM_DECL: - *decl = t; - *offset = bitsize_int (0L, 0L); - *size = TYPE_SIZE (TREE_TYPE (t)); - return; +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_dims_ (ffesymbol s) +{ + if (ffesymbol_dims (s) == NULL) + return convert (ffecom_f2c_ptr_to_ftnlen_type_node, + integer_zero_node); - case ARRAY_REF: + { + ffebld b; + ffebld e; + tree list; + tree backlist; + tree item = NULL_TREE; + tree var; + int yes; + tree numdim; + tree numelem; + tree baseoff = NULL_TREE; + static int mynumber = 0; + + numdim = build_int_2 ((int) ffesymbol_rank (s), 0); + TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node; + + numelem = ffecom_expr (ffesymbol_arraysize (s)); + TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node; + + list = NULL_TREE; + backlist = NULL_TREE; + for (b = ffesymbol_dims (s), e = ffesymbol_extents (s); + b != NULL; + b = ffebld_trail (b), e = ffebld_trail (e)) { - tree array = TREE_OPERAND (t, 0); - tree element = TREE_OPERAND (t, 1); - tree init_offset; + tree t; + tree low; + tree back; - if ((array == NULL_TREE) - || (element == NULL_TREE)) + if (ffebld_trail (b) == NULL) + t = NULL_TREE; + else { - *decl = error_mark_node; - return; - } + t = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (ffebld_head (e))); - ffecom_tree_canonize_ref_ (decl, &init_offset, size, - array); - if ((*decl == NULL_TREE) - || (*decl == error_mark_node)) - return; + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } - *offset = size_binop (MULT_EXPR, - TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))), - size_binop (MINUS_EXPR, - element, - TYPE_MIN_VALUE - (TYPE_DOMAIN - (TREE_TYPE (array))))); + if (ffebld_left (ffebld_head (b)) == NULL) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (ffebld_head (b))); + low = convert (ffecom_f2c_ftnlen_type_node, low); - *offset = size_binop (PLUS_EXPR, - init_offset, - *offset); + back = build_tree_list (low, t); + TREE_CHAIN (back) = backlist; + backlist = back; + } - *size = TYPE_SIZE (TREE_TYPE (t)); - return; + for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item)) + { + if (TREE_VALUE (item) == NULL_TREE) + baseoff = TREE_PURPOSE (item); + else + baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + TREE_PURPOSE (item), + ffecom_2 (MULT_EXPR, + ffecom_f2c_ftnlen_type_node, + TREE_VALUE (item), + baseoff)); } - case INDIRECT_REF: + /* backlist now dead, along with all TREE_PURPOSEs on it. */ - /* Most of this code is to handle references to COMMON. And so - far that is useful only for calling library functions, since - external (user) functions might reference common areas. But - even calling an external function, it's worthwhile to decode - COMMON references because if not storing into COMMON, we don't - want COMMON-based arguments to gratuitously force use of a - temporary. */ + baseoff = build_tree_list (NULL_TREE, baseoff); + TREE_CHAIN (baseoff) = list; - *size = TYPE_SIZE (TREE_TYPE (t)); + numelem = build_tree_list (NULL_TREE, numelem); + TREE_CHAIN (numelem) = baseoff; - ffecom_tree_canonize_ptr_ (decl, offset, - TREE_OPERAND (t, 0)); + numdim = build_tree_list (NULL_TREE, numdim); + TREE_CHAIN (numdim) = numelem; - return; + yes = suspend_momentary (); - case CONVERT_EXPR: - case NOP_EXPR: - case MODIFY_EXPR: - case NON_LVALUE_EXPR: - case RESULT_DECL: - case FIELD_DECL: - case COND_EXPR: /* More cases than we can handle. */ - case SAVE_EXPR: - case REFERENCE_EXPR: - case PREDECREMENT_EXPR: - case PREINCREMENT_EXPR: - case POSTDECREMENT_EXPR: - case POSTINCREMENT_EXPR: - case CALL_EXPR: - default: - *decl = error_mark_node; - return; - } + item = build_array_type (ffecom_f2c_ftnlen_type_node, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 + ((int) ffesymbol_rank (s) + + 2, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, numdim); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + + var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); + + var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var); + + resume_momentary (yes); + + return var; + } } + #endif +/* Essentially does a "fold (build1 (code, type, node))" while checking + for certain housekeeping things. -/* Do divide operation appropriate to type of operands. */ + NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use + ffecom_1_fn instead. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_tree_divide_ (tree tree_type, tree left, tree right, - tree dest_tree, ffebld dest, bool *dest_used) +tree +ffecom_1 (enum tree_code code, tree type, tree node) { - if ((left == error_mark_node) - || (right == error_mark_node)) + tree item; + + if ((node == error_mark_node) + || (type == error_mark_node)) return error_mark_node; - switch (TREE_CODE (tree_type)) + if (code == ADDR_EXPR) { - case INTEGER_TYPE: - return ffecom_2 (TRUNC_DIV_EXPR, tree_type, - left, - right); - - case COMPLEX_TYPE: - { - ffecomGfrt ix; - - if (TREE_TYPE (tree_type) - == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) - ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ - else - ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + if (!mark_addressable (node)) + assert ("can't mark_addressable this node!" == NULL); + } - left = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (left)), - left); - left = build_tree_list (NULL_TREE, left); - right = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (right)), - right); - right = build_tree_list (NULL_TREE, right); - TREE_CHAIN (left) = right; + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + { + tree realtype; - return ffecom_call_ (ffecom_gfrt_tree_ (ix), - ffecom_gfrt_kindtype (ix), - ffe_is_f2c_library (), - tree_type, - left, - dest_tree, dest, dest_used, - NULL_TREE, TRUE); - } + case REALPART_EXPR: + item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node))); break; - case RECORD_TYPE: - { - ffecomGfrt ix; - - if (TREE_TYPE (TYPE_FIELDS (tree_type)) - == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) - ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ - else - ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + case IMAGPART_EXPR: + item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node)))); + break; - left = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (left)), - left); - left = build_tree_list (NULL_TREE, left); - right = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (right)), - right); - right = build_tree_list (NULL_TREE, right); - TREE_CHAIN (left) = right; - return ffecom_call_ (ffecom_gfrt_tree_ (ix), - ffecom_gfrt_kindtype (ix), - ffe_is_f2c_library (), - tree_type, - left, - dest_tree, dest, dest_used, - NULL_TREE, TRUE); - } + case NEGATE_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build1 (code, type, node); + break; + } + node = ffecom_stabilize_aggregate_ (node); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node)), + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node))); break; default: - return ffecom_2 (RDIV_EXPR, tree_type, - left, - right); + item = build1 (code, type, node); + break; } -} + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if ((code == ADDR_EXPR) && staticp (node)) + TREE_CONSTANT (item) = 1; + return fold (item); +} #endif -/* ffecom_type_localvar_ -- Build type info for non-dummy variable - - tree type; - ffesymbol s; // the variable's symbol - ffeinfoBasictype bt; // it's basictype - ffeinfoKindtype kt; // it's kindtype - type = ffecom_type_localvar_(s,bt,kt); - - Handles static arrays, CHARACTER type, etc. */ +/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except + handles TREE_CODE (node) == FUNCTION_DECL. In particular, + does not set TREE_ADDRESSABLE (because calling an inline + function does not mean the function needs to be separately + compiled). */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, - ffeinfoKindtype kt) +tree +ffecom_1_fn (tree node) { + tree item; tree type; - ffebld dl; - ffebld dim; - tree lowt; - tree hight; - - type = ffecom_tree_type[bt][kt]; - if (bt == FFEINFO_basictypeCHARACTER) - { - hight = build_int_2 (ffesymbol_size (s), 0); - TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node; - - type - = build_array_type - (type, - build_range_type (ffecom_f2c_ftnlen_type_node, - ffecom_f2c_ftnlen_one_node, - hight)); - type = ffecom_check_size_overflow_ (s, type, FALSE); - } - - for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) - { - if (type == error_mark_node) - break; - - dim = ffebld_head (dl); - assert (ffebld_op (dim) == FFEBLD_opBOUNDS); - - if (ffebld_left (dim) == NULL) - lowt = integer_one_node; - else - lowt = ffecom_expr (ffebld_left (dim)); - if (TREE_CODE (lowt) != INTEGER_CST) - lowt = variable_size (lowt); - - assert (ffebld_right (dim) != NULL); - hight = ffecom_expr (ffebld_right (dim)); - - if (TREE_CODE (hight) != INTEGER_CST) - hight = variable_size (hight); - - type = build_array_type (type, - build_range_type (ffecom_integer_type_node, - lowt, hight)); - type = ffecom_check_size_overflow_ (s, type, FALSE); - } + if (node == error_mark_node) + return error_mark_node; - return type; + type = build_type_variant (TREE_TYPE (node), + TREE_READONLY (node), + TREE_THIS_VOLATILE (node)); + item = build1 (ADDR_EXPR, + build_pointer_type (type), node); + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if (staticp (node)) + TREE_CONSTANT (item) = 1; + return fold (item); } - #endif -/* Build Namelist type. */ + +/* Essentially does a "fold (build (code, type, node1, node2))" while + checking for certain housekeeping things. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_type_namelist_ () +tree +ffecom_2 (enum tree_code code, tree type, tree node1, + tree node2) { - static tree type = NULL_TREE; + tree item; - if (type == NULL_TREE) + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) { - static tree namefield, varsfield, nvarsfield; - tree vardesctype; + tree a, b, c, d, realtype; - vardesctype = ffecom_type_vardesc_ (); + case CONJ_EXPR: + assert ("no CONJ_EXPR support yet" == NULL); + return error_mark_node; - push_obstacks_nochange (); - end_temporary_allocation (); + case COMPLEX_EXPR: + item = build_tree_list (TYPE_FIELDS (type), node1); + TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2); + item = build (CONSTRUCTOR, type, NULL_TREE, item); + break; - type = make_node (RECORD_TYPE); + case PLUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; - vardesctype = build_pointer_type (build_pointer_type (vardesctype)); + case MINUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; - namefield = ffecom_decl_field (type, NULL_TREE, "name", - string_type_node); - varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype); - nvarsfield = ffecom_decl_field (type, varsfield, "nvars", - integer_type_node); + case MULT_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + a = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node1)); + b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node1)); + c = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node2)); + d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node2)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + c), + ffecom_2 (MULT_EXPR, realtype, + b, + d)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + d), + ffecom_2 (MULT_EXPR, realtype, + c, + b))); + break; - TYPE_FIELDS (type) = namefield; - layout_type (type); + case EQ_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ANDIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case NE_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ORIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; - resume_temporary_allocation (); - pop_obstacks (); + default: + item = build (code, type, node1, node2); + break; } - return type; + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)) + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); } #endif +/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint -/* Make a copy of a type, assuming caller has switched to the permanent - obstacks and that the type is for an aggregate (array) initializer. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */ -static tree -ffecom_type_permanent_copy_ (tree t) -{ - tree domain; - tree max; - - assert (TREE_TYPE (t) != NULL_TREE); - - domain = TYPE_DOMAIN (t); - - assert (TREE_CODE (t) == ARRAY_TYPE); - assert (TREE_PERMANENT (TREE_TYPE (t))); - assert (TREE_PERMANENT (TREE_TYPE (domain))); - assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain))); - - max = TYPE_MAX_VALUE (domain); - if (!TREE_PERMANENT (max)) - { - assert (TREE_CODE (max) == INTEGER_CST); + ffesymbol s; // the ENTRY point itself + if (ffecom_2pass_advise_entrypoint(s)) + // the ENTRY point has been accepted - max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max)); - TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain)); - } + Does whatever compiler needs to do when it learns about the entrypoint, + like determine the return type of the master function, count the + number of entrypoints, etc. Returns FALSE if the return type is + not compatible with the return type(s) of other entrypoint(s). - return build_array_type (TREE_TYPE (t), - build_range_type (TREE_TYPE (domain), - TYPE_MIN_VALUE (domain), - max)); -} -#endif + NOTE: for every call to this fn that returns TRUE, _do_entrypoint must + later (after _finish_progunit) be called with the same entrypoint(s) + as passed to this fn for which TRUE was returned. -/* Build Vardesc type. */ + 03-Jan-92 JCB 2.0 + Return FALSE if the return type conflicts with previous entrypoints. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_type_vardesc_ () +bool +ffecom_2pass_advise_entrypoint (ffesymbol entry) { - static tree type = NULL_TREE; - static tree namefield, addrfield, dimsfield, typefield; - - if (type == NULL_TREE) - { - push_obstacks_nochange (); - end_temporary_allocation (); - - type = make_node (RECORD_TYPE); + ffebld list; /* opITEM. */ + ffebld mlist; /* opITEM. */ + ffebld plist; /* opITEM. */ + ffebld arg; /* ffebld_head(opITEM). */ + ffebld item; /* opITEM. */ + ffesymbol s; /* ffebld_symter(arg). */ + ffeinfoBasictype bt = ffesymbol_basictype (entry); + ffeinfoKindtype kt = ffesymbol_kindtype (entry); + ffetargetCharacterSize size = ffesymbol_size (entry); + bool ok; - namefield = ffecom_decl_field (type, NULL_TREE, "name", - string_type_node); - addrfield = ffecom_decl_field (type, namefield, "addr", - string_type_node); - dimsfield = ffecom_decl_field (type, addrfield, "dims", - ffecom_f2c_ptr_to_ftnlen_type_node); - typefield = ffecom_decl_field (type, dimsfield, "type", - integer_type_node); + if (ffecom_num_entrypoints_ == 0) + { /* First entrypoint, make list of main + arglist's dummies. */ + assert (ffecom_primary_entry_ != NULL); - TYPE_FIELDS (type) = namefield; - layout_type (type); + ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_); + ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_); + ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_); - resume_temporary_allocation (); - pop_obstacks (); + for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); + plist = item; + } } - return type; -} - -#endif - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_vardesc_ (ffebld expr) -{ - ffesymbol s; - - assert (ffebld_op (expr) == FFEBLD_opSYMTER); - s = ffebld_symter (expr); + /* If necessary, scan entry arglist for alternate returns. Do this scan + apparently redundantly (it's done below to UNIONize the arglists) so + that we don't complain about RETURN 1 if an offending ENTRY is the only + one with an alternate return. */ - if (ffesymbol_hook (s).vardesc_tree == NULL_TREE) + if (!ffecom_is_altreturning_) { - int i; - tree vardesctype = ffecom_type_vardesc_ (); - tree var; - tree nameinit; - tree dimsinit; - tree addrinit; - tree typeinit; - tree field; - tree varinits; - int yes; - static int mynumber = 0; - - yes = suspend_momentary (); - - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_vardesc_%d", - NULL, mynumber++), - vardesctype); - TREE_STATIC (var) = 1; - DECL_INITIAL (var) = error_mark_node; - - var = start_decl (var, FALSE); + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } - /* Process inits. */ + /* Now check type compatibility. */ - nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) - + 1, - ffesymbol_text (s)); - TREE_TYPE (nameinit) - = build_type_variant - (build_array_type - (char_type_node, - build_range_type (integer_type_node, - integer_one_node, - build_int_2 (i, 0))), - 1, 0); - TREE_CONSTANT (nameinit) = 1; - TREE_STATIC (nameinit) = 1; - nameinit = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (nameinit)), - nameinit); + switch (ffecom_master_bt_) + { + case FFEINFO_basictypeNONE: + ok = (bt != FFEINFO_basictypeCHARACTER); + break; - addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit); + case FFEINFO_basictypeCHARACTER: + ok + = (bt == FFEINFO_basictypeCHARACTER) + && (kt == ffecom_master_kt_) + && (size == ffecom_master_size_); + break; - dimsinit = ffecom_vardesc_dims_ (s); + case FFEINFO_basictypeANY: + return FALSE; /* Just don't bother. */ - if (typeinit == NULL_TREE) + default: + if (bt == FFEINFO_basictypeCHARACTER) { - ffeinfoBasictype bt = ffesymbol_basictype (s); - ffeinfoKindtype kt = ffesymbol_kindtype (s); - int tc = ffecom_f2c_typecode (bt, kt); - - assert (tc != -1); - typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0); + ok = FALSE; + break; } - else - typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit); + ok = TRUE; + if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_)) + { + ffecom_master_bt_ = FFEINFO_basictypeNONE; + ffecom_master_kt_ = FFEINFO_kindtypeNONE; + } + break; + } - varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)), - nameinit); - TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)), - addrinit); - TREE_CHAIN (TREE_CHAIN (varinits)) - = build_tree_list ((field = TREE_CHAIN (field)), dimsinit); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits))) - = build_tree_list ((field = TREE_CHAIN (field)), typeinit); + if (!ok) + { + ffebad_start (FFEBAD_ENTRY_CONFLICTS); + ffest_ffebad_here_current_stmt (0); + ffebad_finish (); + return FALSE; /* Can't handle entrypoint. */ + } - varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits); - TREE_CONSTANT (varinits) = 1; - TREE_STATIC (varinits) = 1; + /* Entrypoint type compatible with previous types. */ - finish_decl (var, varinits, FALSE); + ++ffecom_num_entrypoints_; - var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); + /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */ + + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + s = ffebld_symter (arg); + for (plist = NULL, mlist = ffecom_master_arglist_; + mlist != NULL; + plist = mlist, mlist = ffebld_trail (mlist)) + { /* plist points to previous item for easy + appending of arg. */ + if (ffebld_symter (ffebld_head (mlist)) == s) + break; /* Already have this arg in the master list. */ + } + if (mlist != NULL) + continue; /* Already have this arg in the master list. */ - resume_momentary (yes); + /* Append this arg to the master list. */ - ffesymbol_hook (s).vardesc_tree = var; + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); } - return ffesymbol_hook (s).vardesc_tree; + return TRUE; } #endif +/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint + + ffesymbol s; // the ENTRY point itself + ffecom_2pass_do_entrypoint(s); + + Does whatever compiler needs to do to make the entrypoint actually + happen. Must be called for each entrypoint after + ffecom_finish_progunit is called. */ + #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_vardesc_array_ (ffesymbol s) +void +ffecom_2pass_do_entrypoint (ffesymbol entry) { - ffebld b; - tree list; - tree item = NULL_TREE; - tree var; - int i; - int yes; - static int mynumber = 0; + static int mfn_num = 0; + static int ent_num; - for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s); - b != NULL; - b = ffebld_trail (b), ++i) - { - tree t; + if (mfn_num != ffecom_num_fns_) + { /* First entrypoint for this program unit. */ + ent_num = 1; + mfn_num = ffecom_num_fns_; + ffecom_do_entry_ (ffecom_primary_entry_, 0); + } + else + ++ent_num; - t = ffecom_vardesc_ (ffebld_head (b)); + --ffecom_num_entrypoints_; - if (list == NULL_TREE) - list = item = build_tree_list (NULL_TREE, t); - else - { - TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); - item = TREE_CHAIN (item); - } - } + ffecom_do_entry_ (entry, ent_num); +} - yes = suspend_momentary (); +#endif - item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()), - build_range_type (integer_type_node, - integer_one_node, - build_int_2 (i, 0))); - list = build (CONSTRUCTOR, item, NULL_TREE, list); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; +/* Essentially does a "fold (build (code, type, node1, node2))" while + checking for certain housekeeping things. Always sets + TREE_SIDE_EFFECTS. */ - var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL, - mynumber++); - var = build_decl (VAR_DECL, var, item); - TREE_STATIC (var) = 1; - DECL_INITIAL (var) = error_mark_node; - var = start_decl (var, FALSE); - finish_decl (var, list, FALSE); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_2s (enum tree_code code, tree type, tree node1, + tree node2) +{ + tree item; - resume_momentary (yes); + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; - return var; + item = build (code, type, node1, node2); + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); } #endif +/* Essentially does a "fold (build (code, type, node1, node2, node3))" while + checking for certain housekeeping things. */ + #if FFECOM_targetCURRENT == FFECOM_targetGCC -static tree -ffecom_vardesc_dims_ (ffesymbol s) +tree +ffecom_3 (enum tree_code code, tree type, tree node1, + tree node2, tree node3) { - if (ffesymbol_dims (s) == NULL) - return convert (ffecom_f2c_ptr_to_ftnlen_type_node, - integer_zero_node); + tree item; - { - ffebld b; - ffebld e; - tree list; - tree backlist; - tree item = NULL_TREE; - tree var; - int yes; - tree numdim; - tree numelem; - tree baseoff = NULL_TREE; - static int mynumber = 0; + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; - numdim = build_int_2 ((int) ffesymbol_rank (s), 0); - TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node; + item = build (code, type, node1, node2, node3); + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2) + || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3))) + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} - numelem = ffecom_expr (ffesymbol_arraysize (s)); - TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node; +#endif +/* Essentially does a "fold (build (code, type, node1, node2, node3))" while + checking for certain housekeeping things. Always sets + TREE_SIDE_EFFECTS. */ - list = NULL_TREE; - backlist = NULL_TREE; - for (b = ffesymbol_dims (s), e = ffesymbol_extents (s); - b != NULL; - b = ffebld_trail (b), e = ffebld_trail (e)) - { - tree t; - tree low; - tree back; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_3s (enum tree_code code, tree type, tree node1, + tree node2, tree node3) +{ + tree item; - if (ffebld_trail (b) == NULL) - t = NULL_TREE; - else - { - t = convert (ffecom_f2c_ftnlen_type_node, - ffecom_expr (ffebld_head (e))); + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; - if (list == NULL_TREE) - list = item = build_tree_list (NULL_TREE, t); - else - { - TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); - item = TREE_CHAIN (item); - } - } + item = build (code, type, node1, node2, node3); + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} - if (ffebld_left (ffebld_head (b)) == NULL) - low = ffecom_integer_one_node; - else - low = ffecom_expr (ffebld_left (ffebld_head (b))); - low = convert (ffecom_f2c_ftnlen_type_node, low); +#endif - back = build_tree_list (low, t); - TREE_CHAIN (back) = backlist; - backlist = back; - } +/* ffecom_arg_expr -- Transform argument expr into gcc tree - for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item)) - { - if (TREE_VALUE (item) == NULL_TREE) - baseoff = TREE_PURPOSE (item); - else - baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, - TREE_PURPOSE (item), - ffecom_2 (MULT_EXPR, - ffecom_f2c_ftnlen_type_node, - TREE_VALUE (item), - baseoff)); - } + See use by ffecom_list_expr. - /* backlist now dead, along with all TREE_PURPOSEs on it. */ + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, but does NOT set the length return value to a tree + that specifies the length of the result. (In other words, the length + variable is always set to NULL_TREE, because a length is never passed.) - baseoff = build_tree_list (NULL_TREE, baseoff); - TREE_CHAIN (baseoff) = list; + 21-Dec-91 JCB 1.1 + Don't set returned length, since nobody needs it (yet; someday if + we allow CHARACTER*(*) dummies to statement functions, we'll need + it). */ - numelem = build_tree_list (NULL_TREE, numelem); - TREE_CHAIN (numelem) = baseoff; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_arg_expr (ffebld expr, tree *length) +{ + tree ign; - numdim = build_tree_list (NULL_TREE, numdim); - TREE_CHAIN (numdim) = numelem; + *length = NULL_TREE; - yes = suspend_momentary (); + if (expr == NULL) + return integer_zero_node; - item = build_array_type (ffecom_f2c_ftnlen_type_node, - build_range_type (integer_type_node, - integer_zero_node, - build_int_2 - ((int) ffesymbol_rank (s) - + 2, 0))); - list = build (CONSTRUCTOR, item, NULL_TREE, numdim); - TREE_CONSTANT (list) = 1; - TREE_STATIC (list) = 1; + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (expr); - var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL, - mynumber++); - var = build_decl (VAR_DECL, var, item); - TREE_STATIC (var) = 1; - DECL_INITIAL (var) = error_mark_node; - var = start_decl (var, FALSE); - finish_decl (var, list, FALSE); + return ffecom_arg_ptr_to_expr (expr, &ign); +} + +#endif +/* Transform expression into constant argument-pointer-to-expression tree. + + If the expression can be transformed into a argument-pointer-to-expression + tree that is constant, that is done, and the tree returned. Else + NULL_TREE is returned. - var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var); + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ - resume_momentary (yes); +tree +ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length) +{ + if (! expr) + return integer_zero_node; - return var; - } + if (ffebld_op (expr) == FFEBLD_opANY) + { + if (length) + *length = error_mark_node; + return error_mark_node; + } + + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER + || ffebld_where (expr) == FFEINFO_whereCOMMON + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) + { + tree t; + + t = ffecom_arg_ptr_to_expr (expr, length); + assert (TREE_CONSTANT (t)); + assert (! length || TREE_CONSTANT (*length)); + return t; + } + + if (length + && ffebld_size (expr) != FFETARGET_charactersizeNONE) + *length = build_int_2 (ffebld_size (expr), 0); + else if (length) + *length = NULL_TREE; + return NULL_TREE; } -#endif -/* Essentially does a "fold (build1 (code, type, node))" while checking - for certain housekeeping things. +/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree - NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use - ffecom_1_fn instead. */ + See use by ffecom_list_ptr_to_expr. + + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_ptr_to_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, AND sets the length return value to a tree that + specifies the length of the result. + + If the length argument is NULL, this is a slightly special + case of building a FORMAT expression, that is, an expression that + will be used at run time without regard to length. For the current + implementation, which uses the libf2c library, this means it is nice + to append a null byte to the end of the expression, where feasible, + to make sure any diagnostic about the FORMAT string terminates at + some useful point. + + For now, treat %REF(char-expr) as the same as char-expr with a NULL + length argument. This might even be seen as a feature, if a null + byte can always be appended. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_1 (enum tree_code code, tree type, tree node) +ffecom_arg_ptr_to_expr (ffebld expr, tree *length) { tree item; + tree ign_length; + ffecomConcatList_ catlist; - if ((node == error_mark_node) - || (type == error_mark_node)) - return error_mark_node; + if (length != NULL) + *length = NULL_TREE; - if (code == ADDR_EXPR) - { - if (!mark_addressable (node)) - assert ("can't mark_addressable this node!" == NULL); - } + if (expr == NULL) + return integer_zero_node; - switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + switch (ffebld_op (expr)) { - tree realtype; + case FFEBLD_opPERCENT_VAL: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (ffebld_left (expr)); + { + tree temp_exp; + tree temp_length; - case REALPART_EXPR: - item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node))); - break; + temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length); + if (temp_exp == error_mark_node) + return error_mark_node; - case IMAGPART_EXPR: - item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node)))); - break; + return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)), + temp_exp); + } + case FFEBLD_opPERCENT_REF: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (ffebld_left (expr)); + if (length != NULL) + { + ign_length = NULL_TREE; + length = &ign_length; + } + expr = ffebld_left (expr); + break; - case NEGATE_EXPR: - if (TREE_CODE (type) != RECORD_TYPE) + case FFEBLD_opPERCENT_DESCR: + switch (ffeinfo_basictype (ffebld_info (expr))) { - item = build1 (code, type, node); +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + case FFEINFO_basictypeHOLLERITH: +#endif + case FFEINFO_basictypeCHARACTER: + break; /* Passed by descriptor anyway. */ + + default: + item = ffecom_ptr_to_expr (expr); + if (item != error_mark_node) + *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item))); break; } - node = ffecom_stabilize_aggregate_ (node); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - item = - ffecom_2 (COMPLEX_EXPR, type, - ffecom_1 (NEGATE_EXPR, realtype, - ffecom_1 (REALPART_EXPR, realtype, - node)), - ffecom_1 (NEGATE_EXPR, realtype, - ffecom_1 (IMAGPART_EXPR, realtype, - node))); break; default: - item = build1 (code, type, node); break; } - if (TREE_SIDE_EFFECTS (node)) +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH) + && (length != NULL)) + { /* Pass Hollerith by descriptor. */ + ffetargetHollerith h; + + assert (ffebld_op (expr) == FFEBLD_opCONTER); + h = ffebld_cu_val_hollerith (ffebld_constant_union + (ffebld_conter (expr))); + *length + = build_int_2 (h.length, 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } +#endif + + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (expr); + + assert (ffeinfo_kindtype (ffebld_info (expr)) + == FFEINFO_kindtypeCHARACTER1); + + catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + if (length != NULL) + { + *length = ffecom_f2c_ftnlen_zero_node; + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } + ffecom_concat_list_kill_ (catlist); + return null_pointer_node; + + case 1: /* The (fairly) easy case. */ + if (length == NULL) + ffecom_char_args_with_null_ (&item, &ign_length, + ffecom_concat_list_expr_ (catlist, 0)); + else + ffecom_char_args_ (&item, length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; + + default: /* Must actually concatenate things. */ + break; + } + + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; + tree temporary; + tree num; + tree known_length; + ffetargetCharacterSize sz; + + sz = ffecom_concat_list_maxlen_ (catlist); + /* ~~Kludge! */ + assert (sz != FFETARGET_charactersizeNONE); + +#ifdef HOHO + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array + = items + = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + temporary = ffecom_push_tempvar (char_type_node, + sz, -1, TRUE); +#else + { + tree hook; + + hook = ffebld_nonter_hook (expr); + assert (hook); + assert (TREE_CODE (hook) == TREE_VEC); + assert (TREE_VEC_LENGTH (hook) == 3); + length_array = lengths = TREE_VEC_ELT (hook, 0); + item_array = items = TREE_VEC_ELT (hook, 1); + temporary = TREE_VEC_ELT (hook, 2); + } +#endif + + known_length = ffecom_f2c_ftnlen_zero_node; + + for (i = 0; i < count; ++i) + { + if ((i == count) + && (length == NULL)) + ffecom_char_args_with_null_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + else + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + *length = error_mark_node; + return error_mark_node; + } + + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + clength = ffecom_save_tree (clength); + if (length != NULL) + known_length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + known_length, + clength); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } + + temporary = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (temporary)), + temporary); + + item = build_tree_list (NULL_TREE, temporary); + TREE_CHAIN (item) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (item)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + num = build_int_2 (sz, 0); + TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node; + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) + = build_tree_list (NULL_TREE, num); + + item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE); TREE_SIDE_EFFECTS (item) = 1; - if ((code == ADDR_EXPR) && staticp (node)) - TREE_CONSTANT (item) = 1; - return fold (item); + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), + item, + temporary); + + if (length != NULL) + *length = known_length; + } + + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; } + #endif +/* Generate call to run-time function. -/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except - handles TREE_CODE (node) == FUNCTION_DECL. In particular, - does not set TREE_ADDRESSABLE (because calling an inline - function does not mean the function needs to be separately - compiled). */ + The first arg is the GNU Fortran Run-Time function index, the second + arg is the list of arguments to pass to it. Returned is the expression + (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the + result (which may be void). */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_1_fn (tree node) +ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook) { - tree item; - tree type; - - if (node == error_mark_node) - return error_mark_node; - - type = build_type_variant (TREE_TYPE (node), - TREE_READONLY (node), - TREE_THIS_VOLATILE (node)); - item = build1 (ADDR_EXPR, - build_pointer_type (type), node); - if (TREE_SIDE_EFFECTS (node)) - TREE_SIDE_EFFECTS (item) = 1; - if (staticp (node)) - TREE_CONSTANT (item) = 1; - return fold (item); + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], + NULL_TREE, args, NULL_TREE, NULL, + NULL, NULL_TREE, TRUE, hook); } #endif -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. */ +/* Transform constant-union to tree. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_2 (enum tree_code code, tree type, tree node1, - tree node2) +ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, + ffeinfoKindtype kt, tree tree_type) { tree item; - if ((node1 == error_mark_node) - || (node2 == error_mark_node) - || (type == error_mark_node)) - return error_mark_node; - - switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + switch (bt) { - tree a, b, c, d, realtype; - - case CONJ_EXPR: - assert ("no CONJ_EXPR support yet" == NULL); - return error_mark_node; - - case COMPLEX_EXPR: - item = build_tree_list (TYPE_FIELDS (type), node1); - TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2); - item = build (CONSTRUCTOR, type, NULL_TREE, item); - break; - - case PLUS_EXPR: - if (TREE_CODE (type) != RECORD_TYPE) - { - item = build (code, type, node1, node2); - break; - } - node1 = ffecom_stabilize_aggregate_ (node1); - node2 = ffecom_stabilize_aggregate_ (node2); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - item = - ffecom_2 (COMPLEX_EXPR, type, - ffecom_2 (PLUS_EXPR, realtype, - ffecom_1 (REALPART_EXPR, realtype, - node1), - ffecom_1 (REALPART_EXPR, realtype, - node2)), - ffecom_2 (PLUS_EXPR, realtype, - ffecom_1 (IMAGPART_EXPR, realtype, - node1), - ffecom_1 (IMAGPART_EXPR, realtype, - node2))); - break; + case FFEINFO_basictypeINTEGER: + { + int val; - case MINUS_EXPR: - if (TREE_CODE (type) != RECORD_TYPE) - { - item = build (code, type, node1, node2); - break; - } - node1 = ffecom_stabilize_aggregate_ (node1); - node2 = ffecom_stabilize_aggregate_ (node2); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - item = - ffecom_2 (COMPLEX_EXPR, type, - ffecom_2 (MINUS_EXPR, realtype, - ffecom_1 (REALPART_EXPR, realtype, - node1), - ffecom_1 (REALPART_EXPR, realtype, - node2)), - ffecom_2 (MINUS_EXPR, realtype, - ffecom_1 (IMAGPART_EXPR, realtype, - node1), - ffecom_1 (IMAGPART_EXPR, realtype, - node2))); - break; + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + val = ffebld_cu_val_integer1 (*cu); + break; +#endif - case MULT_EXPR: - if (TREE_CODE (type) != RECORD_TYPE) - { - item = build (code, type, node1, node2); - break; - } - node1 = ffecom_stabilize_aggregate_ (node1); - node2 = ffecom_stabilize_aggregate_ (node2); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - a = save_expr (ffecom_1 (REALPART_EXPR, realtype, - node1)); - b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, - node1)); - c = save_expr (ffecom_1 (REALPART_EXPR, realtype, - node2)); - d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, - node2)); - item = - ffecom_2 (COMPLEX_EXPR, type, - ffecom_2 (MINUS_EXPR, realtype, - ffecom_2 (MULT_EXPR, realtype, - a, - c), - ffecom_2 (MULT_EXPR, realtype, - b, - d)), - ffecom_2 (PLUS_EXPR, realtype, - ffecom_2 (MULT_EXPR, realtype, - a, - d), - ffecom_2 (MULT_EXPR, realtype, - c, - b))); - break; +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + val = ffebld_cu_val_integer2 (*cu); + break; +#endif - case EQ_EXPR: - if ((TREE_CODE (node1) != RECORD_TYPE) - && (TREE_CODE (node2) != RECORD_TYPE)) - { - item = build (code, type, node1, node2); - break; - } - assert (TREE_CODE (node1) == RECORD_TYPE); - assert (TREE_CODE (node2) == RECORD_TYPE); - node1 = ffecom_stabilize_aggregate_ (node1); - node2 = ffecom_stabilize_aggregate_ (node2); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - item = - ffecom_2 (TRUTH_ANDIF_EXPR, type, - ffecom_2 (code, type, - ffecom_1 (REALPART_EXPR, realtype, - node1), - ffecom_1 (REALPART_EXPR, realtype, - node2)), - ffecom_2 (code, type, - ffecom_1 (IMAGPART_EXPR, realtype, - node1), - ffecom_1 (IMAGPART_EXPR, realtype, - node2))); - break; +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + val = ffebld_cu_val_integer3 (*cu); + break; +#endif - case NE_EXPR: - if ((TREE_CODE (node1) != RECORD_TYPE) - && (TREE_CODE (node2) != RECORD_TYPE)) - { - item = build (code, type, node1, node2); - break; - } - assert (TREE_CODE (node1) == RECORD_TYPE); - assert (TREE_CODE (node2) == RECORD_TYPE); - node1 = ffecom_stabilize_aggregate_ (node1); - node2 = ffecom_stabilize_aggregate_ (node2); - realtype = TREE_TYPE (TYPE_FIELDS (type)); - item = - ffecom_2 (TRUTH_ORIF_EXPR, type, - ffecom_2 (code, type, - ffecom_1 (REALPART_EXPR, realtype, - node1), - ffecom_1 (REALPART_EXPR, realtype, - node2)), - ffecom_2 (code, type, - ffecom_1 (IMAGPART_EXPR, realtype, - node1), - ffecom_1 (IMAGPART_EXPR, realtype, - node2))); - break; +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + val = ffebld_cu_val_integer4 (*cu); + break; +#endif - default: - item = build (code, type, node1, node2); + default: + assert ("bad INTEGER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } break; - } - if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)) - TREE_SIDE_EFFECTS (item) = 1; - return fold (item); -} + case FFEINFO_basictypeLOGICAL: + { + int val; + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_logical1 (*cu); + break; #endif -/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint - - ffesymbol s; // the ENTRY point itself - if (ffecom_2pass_advise_entrypoint(s)) - // the ENTRY point has been accepted - - Does whatever compiler needs to do when it learns about the entrypoint, - like determine the return type of the master function, count the - number of entrypoints, etc. Returns FALSE if the return type is - not compatible with the return type(s) of other entrypoint(s). - NOTE: for every call to this fn that returns TRUE, _do_entrypoint must - later (after _finish_progunit) be called with the same entrypoint(s) - as passed to this fn for which TRUE was returned. +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + val = ffebld_cu_val_logical2 (*cu); + break; +#endif - 03-Jan-92 JCB 2.0 - Return FALSE if the return type conflicts with previous entrypoints. */ +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + val = ffebld_cu_val_logical3 (*cu); + break; +#endif -#if FFECOM_targetCURRENT == FFECOM_targetGCC -bool -ffecom_2pass_advise_entrypoint (ffesymbol entry) -{ - ffebld list; /* opITEM. */ - ffebld mlist; /* opITEM. */ - ffebld plist; /* opITEM. */ - ffebld arg; /* ffebld_head(opITEM). */ - ffebld item; /* opITEM. */ - ffesymbol s; /* ffebld_symter(arg). */ - ffeinfoBasictype bt = ffesymbol_basictype (entry); - ffeinfoKindtype kt = ffesymbol_kindtype (entry); - ffetargetCharacterSize size = ffesymbol_size (entry); - bool ok; +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + val = ffebld_cu_val_logical4 (*cu); + break; +#endif - if (ffecom_num_entrypoints_ == 0) - { /* First entrypoint, make list of main - arglist's dummies. */ - assert (ffecom_primary_entry_ != NULL); + default: + assert ("bad LOGICAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } + break; - ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_); - ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_); - ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_); + case FFEINFO_basictypeREAL: + { + REAL_VALUE_TYPE val; - for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_); - list != NULL; - list = ffebld_trail (list)) - { - arg = ffebld_head (list); - if (ffebld_op (arg) != FFEBLD_opSYMTER) - continue; /* Alternate return or some such thing. */ - item = ffebld_new_item (arg, NULL); - if (plist == NULL) - ffecom_master_arglist_ = item; - else - ffebld_set_trail (plist, item); - plist = item; - } - } + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu)); + break; +#endif - /* If necessary, scan entry arglist for alternate returns. Do this scan - apparently redundantly (it's done below to UNIONize the arglists) so - that we don't complain about RETURN 1 if an offending ENTRY is the only - one with an alternate return. */ +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu)); + break; +#endif - if (!ffecom_is_altreturning_) - { - for (list = ffesymbol_dummyargs (entry); - list != NULL; - list = ffebld_trail (list)) - { - arg = ffebld_head (list); - if (ffebld_op (arg) == FFEBLD_opSTAR) - { - ffecom_is_altreturning_ = TRUE; - break; - } - } - } +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu)); + break; +#endif - /* Now check type compatibility. */ +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu)); + break; +#endif - switch (ffecom_master_bt_) - { - case FFEINFO_basictypeNONE: - ok = (bt != FFEINFO_basictypeCHARACTER); + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_real (tree_type, val); + } break; - case FFEINFO_basictypeCHARACTER: - ok - = (bt == FFEINFO_basictypeCHARACTER) - && (kt == ffecom_master_kt_) - && (size == ffecom_master_size_); - break; + case FFEINFO_basictypeCOMPLEX: + { + REAL_VALUE_TYPE real; + REAL_VALUE_TYPE imag; + tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; - case FFEINFO_basictypeANY: - return FALSE; /* Just don't bother. */ + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real); + imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary); + break; +#endif - default: - if (bt == FFEINFO_basictypeCHARACTER) - { - ok = FALSE; - break; - } - ok = TRUE; - if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_)) - { - ffecom_master_bt_ = FFEINFO_basictypeNONE; - ffecom_master_kt_ = FFEINFO_kindtypeNONE; - } - break; - } +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real); + imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary); + break; +#endif - if (!ok) - { - ffebad_start (FFEBAD_ENTRY_CONFLICTS); - ffest_ffebad_here_current_stmt (0); - ffebad_finish (); - return FALSE; /* Can't handle entrypoint. */ - } +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real); + imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary); + break; +#endif - /* Entrypoint type compatible with previous types. */ +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real); + imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary); + break; +#endif - ++ffecom_num_entrypoints_; + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = ffecom_build_complex_constant_ (tree_type, + build_real (el_type, real), + build_real (el_type, imag)); + } + break; - /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */ + case FFEINFO_basictypeCHARACTER: + { /* Happens only in DATA and similar contexts. */ + ffetargetCharacter1 val; - for (list = ffesymbol_dummyargs (entry); - list != NULL; - list = ffebld_trail (list)) - { - arg = ffebld_head (list); - if (ffebld_op (arg) != FFEBLD_opSYMTER) - continue; /* Alternate return or some such thing. */ - s = ffebld_symter (arg); - for (plist = NULL, mlist = ffecom_master_arglist_; - mlist != NULL; - plist = mlist, mlist = ffebld_trail (mlist)) - { /* plist points to previous item for easy - appending of arg. */ - if (ffebld_symter (ffebld_head (mlist)) == s) - break; /* Already have this arg in the master list. */ - } - if (mlist != NULL) - continue; /* Already have this arg in the master list. */ + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_character1 (*cu); + break; +#endif + + default: + assert ("bad CHARACTER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_string (ffetarget_length_character1 (val), + ffetarget_text_character1 (val)); + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (ffetarget_length_character1 + (val), 0))), + 1, 0); + } + break; - /* Append this arg to the master list. */ + case FFEINFO_basictypeHOLLERITH: + { + ffetargetHollerith h; - item = ffebld_new_item (arg, NULL); - if (plist == NULL) - ffecom_master_arglist_ = item; - else - ffebld_set_trail (plist, item); - } + h = ffebld_cu_val_hollerith (*cu); - return TRUE; -} + /* If not at least as wide as default INTEGER, widen it. */ + if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE) + item = build_string (h.length, h.text); + else + { + char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE]; -#endif -/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint + memcpy (str, h.text, h.length); + memset (&str[h.length], ' ', + FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE + - h.length); + item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE, + str); + } + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (h.length, 0))), + 1, 0); + } + break; - ffesymbol s; // the ENTRY point itself - ffecom_2pass_do_entrypoint(s); + case FFEINFO_basictypeTYPELESS: + { + ffetargetInteger1 ival; + ffetargetTypeless tless; + ffebad error; - Does whatever compiler needs to do to make the entrypoint actually - happen. Must be called for each entrypoint after - ffecom_finish_progunit is called. */ + tless = ffebld_cu_val_typeless (*cu); + error = ffetarget_convert_integer1_typeless (&ival, tless); + assert (error == FFEBAD); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_2pass_do_entrypoint (ffesymbol entry) -{ - static int mfn_num = 0; - static int ent_num; + item = build_int_2 ((int) ival, 0); + } + break; - if (mfn_num != ffecom_num_fns_) - { /* First entrypoint for this program unit. */ - ent_num = 1; - mfn_num = ffecom_num_fns_; - ffecom_do_entry_ (ffecom_primary_entry_, 0); + default: + assert ("not yet on constant type" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; } - else - ++ent_num; - --ffecom_num_entrypoints_; + TREE_CONSTANT (item) = 1; - ffecom_do_entry_ (entry, ent_num); + return item; } #endif -/* Essentially does a "fold (build (code, type, node1, node2))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ +/* Transform expression into constant tree. + + If the expression can be transformed into a tree that is constant, + that is done, and the tree returned. Else NULL_TREE is returned. + + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_2s (enum tree_code code, tree type, tree node1, - tree node2) +ffecom_const_expr (ffebld expr) { - tree item; + if (! expr) + return integer_zero_node; - if ((node1 == error_mark_node) - || (node2 == error_mark_node) - || (type == error_mark_node)) + if (ffebld_op (expr) == FFEBLD_opANY) return error_mark_node; - item = build (code, type, node1, node2); - TREE_SIDE_EFFECTS (item) = 1; - return fold (item); -} - + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER +#if NEWCOMMON + /* ~~Enable once common/equivalence is handled properly? */ + || ffebld_where (expr) == FFEINFO_whereCOMMON #endif -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_3 (enum tree_code code, tree type, tree node1, - tree node2, tree node3) -{ - tree item; + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) + { + tree t; - if ((node1 == error_mark_node) - || (node2 == error_mark_node) - || (node3 == error_mark_node) - || (type == error_mark_node)) - return error_mark_node; + t = ffecom_expr (expr); + assert (TREE_CONSTANT (t)); + return t; + } - item = build (code, type, node1, node2, node3); - if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2) - || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3))) - TREE_SIDE_EFFECTS (item) = 1; - return fold (item); + return NULL_TREE; } -#endif -/* Essentially does a "fold (build (code, type, node1, node2, node3))" while - checking for certain housekeeping things. Always sets - TREE_SIDE_EFFECTS. */ +/* Handy way to make a field in a struct/union. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_3s (enum tree_code code, tree type, tree node1, - tree node2, tree node3) +ffecom_decl_field (tree context, tree prevfield, + const char *name, tree type) { - tree item; + tree field; - if ((node1 == error_mark_node) - || (node2 == error_mark_node) - || (node3 == error_mark_node) - || (type == error_mark_node)) - return error_mark_node; + field = build_decl (FIELD_DECL, get_identifier (name), type); + DECL_CONTEXT (field) = context; + DECL_FRAME_SIZE (field) = 0; + if (prevfield != NULL_TREE) + TREE_CHAIN (prevfield) = field; - item = build (code, type, node1, node2, node3); - TREE_SIDE_EFFECTS (item) = 1; - return fold (item); + return field; } #endif -/* ffecom_arg_expr -- Transform argument expr into gcc tree - See use by ffecom_list_expr. +void +ffecom_close_include (FILE *f) +{ +#if FFECOM_GCC_INCLUDE + ffecom_close_include_ (f); +#endif +} - If expression is NULL, returns an integer zero tree. If it is not - a CHARACTER expression, returns whatever ffecom_expr - returns and sets the length return value to NULL_TREE. Otherwise - generates code to evaluate the character expression, returns the proper - pointer to the result, but does NOT set the length return value to a tree - that specifies the length of the result. (In other words, the length - variable is always set to NULL_TREE, because a length is never passed.) +int +ffecom_decode_include_option (char *spec) +{ +#if FFECOM_GCC_INCLUDE + return ffecom_decode_include_option_ (spec); +#else + return 1; +#endif +} - 21-Dec-91 JCB 1.1 - Don't set returned length, since nobody needs it (yet; someday if - we allow CHARACTER*(*) dummies to statement functions, we'll need - it). */ +/* End a compound statement (block). */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_arg_expr (ffebld expr, tree *length) +ffecom_end_compstmt (void) { - tree ign; - - *length = NULL_TREE; + return bison_rule_compstmt_ (); +} +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ - if (expr == NULL) - return integer_zero_node; +/* ffecom_end_transition -- Perform end transition on all symbols - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_expr (expr); + ffecom_end_transition(); - return ffecom_arg_ptr_to_expr (expr, &ign); -} + Calls ffecom_sym_end_transition for each global and local symbol. */ +void +ffecom_end_transition () +{ +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffebld item; #endif -/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree - - See use by ffecom_list_ptr_to_expr. - If expression is NULL, returns an integer zero tree. If it is not - a CHARACTER expression, returns whatever ffecom_ptr_to_expr - returns and sets the length return value to NULL_TREE. Otherwise - generates code to evaluate the character expression, returns the proper - pointer to the result, AND sets the length return value to a tree that - specifies the length of the result. + if (ffe_is_ffedebug ()) + fprintf (dmpout, "; end_stmt_transition\n"); - If the length argument is NULL, this is a slightly special - case of building a FORMAT expression, that is, an expression that - will be used at run time without regard to length. For the current - implementation, which uses the libf2c library, this means it is nice - to append a null byte to the end of the expression, where feasible, - to make sure any diagnostic about the FORMAT string terminates at - some useful point. +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffecom_list_blockdata_ = NULL; + ffecom_list_common_ = NULL; +#endif - For now, treat %REF(char-expr) as the same as char-expr with a NULL - length argument. This might even be seen as a feature, if a null - byte can always be appended. */ + ffesymbol_drive (ffecom_sym_end_transition); + if (ffe_is_ffedebug ()) + { + ffestorag_report (); +#if FFECOM_targetCURRENT == FFECOM_targetFFE + ffesymbol_report_all (); +#endif + } #if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_arg_ptr_to_expr (ffebld expr, tree *length) -{ - tree item; - tree ign_length; - ffecomConcatList_ catlist; + ffecom_start_progunit_ (); + + for (item = ffecom_list_blockdata_; + item != NULL; + item = ffebld_trail (item)) + { + ffebld callee; + ffesymbol s; + tree dt; + tree t; + tree var; + int yes; + static int number = 0; + + callee = ffebld_head (item); + s = ffebld_symter (callee); + t = ffesymbol_hook (s).decl_tree; + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + } - if (length != NULL) - *length = NULL_TREE; + yes = suspend_momentary (); - if (expr == NULL) - return integer_zero_node; + dt = build_pointer_type (TREE_TYPE (t)); - switch (ffebld_op (expr)) - { - case FFEBLD_opPERCENT_VAL: - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_expr (ffebld_left (expr)); - { - tree temp_exp; - tree temp_length; + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_forceload_%d", + NULL, number++), + dt); + DECL_EXTERNAL (var) = 0; + TREE_STATIC (var) = 1; + TREE_PUBLIC (var) = 0; + DECL_INITIAL (var) = error_mark_node; + TREE_USED (var) = 1; - temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length); - if (temp_exp == error_mark_node) - return error_mark_node; + var = start_decl (var, FALSE); - return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)), - temp_exp); - } + t = ffecom_1 (ADDR_EXPR, dt, t); - case FFEBLD_opPERCENT_REF: - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_ptr_to_expr (ffebld_left (expr)); - if (length != NULL) - { - ign_length = NULL_TREE; - length = &ign_length; - } - expr = ffebld_left (expr); - break; + finish_decl (var, t, FALSE); - case FFEBLD_opPERCENT_DESCR: - switch (ffeinfo_basictype (ffebld_info (expr))) - { -#ifdef PASS_HOLLERITH_BY_DESCRIPTOR - case FFEINFO_basictypeHOLLERITH: + resume_momentary (yes); + } + + /* This handles any COMMON areas that weren't referenced but have, for + example, important initial data. */ + + for (item = ffecom_list_common_; + item != NULL; + item = ffebld_trail (item)) + ffecom_transform_common_ (ffebld_symter (ffebld_head (item))); + + ffecom_list_common_ = NULL; #endif - case FFEINFO_basictypeCHARACTER: - break; /* Passed by descriptor anyway. */ +} - default: - item = ffecom_ptr_to_expr (expr); - if (item != error_mark_node) - *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item))); - break; - } - break; +/* ffecom_exec_transition -- Perform exec transition on all symbols - default: - break; - } + ffecom_exec_transition(); -#ifdef PASS_HOLLERITH_BY_DESCRIPTOR - if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH) - && (length != NULL)) - { /* Pass Hollerith by descriptor. */ - ffetargetHollerith h; + Calls ffecom_sym_exec_transition for each global and local symbol. + Make sure error updating not inhibited. */ - assert (ffebld_op (expr) == FFEBLD_opCONTER); - h = ffebld_cu_val_hollerith (ffebld_constant_union - (ffebld_conter (expr))); - *length - = build_int_2 (h.length, 0); - TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; - } -#endif +void +ffecom_exec_transition () +{ + bool inhibited; - if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) - return ffecom_ptr_to_expr (expr); + if (ffe_is_ffedebug ()) + fprintf (dmpout, "; exec_stmt_transition\n"); - assert (ffeinfo_kindtype (ffebld_info (expr)) - == FFEINFO_kindtypeCHARACTER1); + inhibited = ffebad_inhibit (); + ffebad_set_inhibit (FALSE); - catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); - switch (ffecom_concat_list_count_ (catlist)) + ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */ + ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */ + if (ffe_is_ffedebug ()) { - case 0: /* Shouldn't happen, but in case it does... */ - if (length != NULL) - { - *length = ffecom_f2c_ftnlen_zero_node; - TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; - } - ffecom_concat_list_kill_ (catlist); - return null_pointer_node; + ffestorag_report (); +#if FFECOM_targetCURRENT == FFECOM_targetFFE + ffesymbol_report_all (); +#endif + } - case 1: /* The (fairly) easy case. */ - if (length == NULL) - ffecom_char_args_with_null_ (&item, &ign_length, - ffecom_concat_list_expr_ (catlist, 0)); - else - ffecom_char_args_ (&item, length, - ffecom_concat_list_expr_ (catlist, 0)); - ffecom_concat_list_kill_ (catlist); - assert (item != NULL_TREE); - return item; + if (inhibited) + ffebad_set_inhibit (TRUE); +} - default: /* Must actually concatenate things. */ - break; - } +/* Handle assignment statement. - { - int count = ffecom_concat_list_count_ (catlist); - int i; - tree lengths; - tree items; - tree length_array; - tree item_array; - tree citem; - tree clength; - tree temporary; - tree num; - tree known_length; - ffetargetCharacterSize sz; + Convert dest and source using ffecom_expr, then join them + with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ - length_array - = lengths - = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, - FFETARGET_charactersizeNONE, count, TRUE); - item_array - = items - = ffecom_push_tempvar (ffecom_f2c_address_type_node, - FFETARGET_charactersizeNONE, count, TRUE); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_expand_let_stmt (ffebld dest, ffebld source) +{ + tree dest_tree; + tree dest_length; + tree source_tree; + tree expr_tree; - known_length = ffecom_f2c_ftnlen_zero_node; + if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER) + { + bool dest_used; - for (i = 0; i < count; ++i) - { - if ((i == count) - && (length == NULL)) - ffecom_char_args_with_null_ (&citem, &clength, - ffecom_concat_list_expr_ (catlist, i)); - else - ffecom_char_args_ (&citem, &clength, - ffecom_concat_list_expr_ (catlist, i)); - if ((citem == error_mark_node) - || (clength == error_mark_node)) - { - ffecom_concat_list_kill_ (catlist); - *length = error_mark_node; - return error_mark_node; - } + /* This attempts to replicate the test below, but must not be + true when the test below is false. (Always err on the side + of creating unused temporaries, to avoid ICEs.) */ + if (ffebld_op (dest) != FFEBLD_opSYMTER + || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree) + && (TREE_CODE (dest_tree) != VAR_DECL + || TREE_ADDRESSABLE (dest_tree)))) + { + ffecom_prepare_expr_ (source, dest); + dest_used = TRUE; + } + else + { + ffecom_prepare_expr_ (source, NULL); + dest_used = FALSE; + } - items - = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), - ffecom_modify (void_type_node, - ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), - item_array, - build_int_2 (i, 0)), - citem), - items); - clength = ffecom_save_tree (clength); - if (length != NULL) - known_length - = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, - known_length, - clength); - lengths - = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), - ffecom_modify (void_type_node, - ffecom_2 (ARRAY_REF, - TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), - length_array, - build_int_2 (i, 0)), - clength), - lengths); - } + ffecom_prepare_expr_w (NULL_TREE, dest); - sz = ffecom_concat_list_maxlen_ (catlist); - assert (sz != FFETARGET_charactersizeNONE); + ffecom_prepare_end (); - temporary = ffecom_push_tempvar (char_type_node, - sz, -1, TRUE); - temporary = ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (temporary)), - temporary); + dest_tree = ffecom_expr_w (NULL_TREE, dest); + if (dest_tree == error_mark_node) + return; - item = build_tree_list (NULL_TREE, temporary); - TREE_CHAIN (item) - = build_tree_list (NULL_TREE, - ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (items)), - items)); - TREE_CHAIN (TREE_CHAIN (item)) - = build_tree_list (NULL_TREE, - ffecom_1 (ADDR_EXPR, - build_pointer_type (TREE_TYPE (lengths)), - lengths)); - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) - = build_tree_list - (NULL_TREE, - ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, - convert (ffecom_f2c_ftnlen_type_node, - build_int_2 (count, 0)))); - num = build_int_2 (sz, 0); - TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node; - TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) - = build_tree_list (NULL_TREE, num); + if ((TREE_CODE (dest_tree) != VAR_DECL) + || TREE_ADDRESSABLE (dest_tree)) + source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used, + FALSE, FALSE); + else + { + assert (! dest_used); + dest_used = FALSE; + source_tree = ffecom_expr (source); + } + if (source_tree == error_mark_node) + return; - item = ffecom_call_gfrt (FFECOM_gfrtCAT, item); - TREE_SIDE_EFFECTS (item) = 1; - item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), - item, - temporary); + if (dest_used) + expr_tree = source_tree; + else + expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, + dest_tree, + source_tree); - if (length != NULL) - *length = known_length; - } + expand_expr_stmt (expr_tree); + return; + } - ffecom_concat_list_kill_ (catlist); - assert (item != NULL_TREE); - return item; + ffecom_prepare_let_char_ (ffebld_size_known (dest), source); + ffecom_prepare_expr_w (NULL_TREE, dest); + + ffecom_prepare_end (); + + ffecom_char_args_ (&dest_tree, &dest_length, dest); + ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), + source); } #endif -/* ffecom_call_gfrt -- Generate call to run-time function +/* ffecom_expr -- Transform expr into gcc tree - tree expr; - expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE); + tree t; + ffebld expr; // FFE expression. + tree = ffecom_expr(expr); - The first arg is the GNU Fortran Run-Time function index, the second - arg is the list of arguments to pass to it. Returned is the expression - (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the - result (which may be void). */ + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_call_gfrt (ffecomGfrt ix, tree args) +ffecom_expr (ffebld expr) { - return ffecom_call_ (ffecom_gfrt_tree_ (ix), - ffecom_gfrt_kindtype (ix), - ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], - NULL_TREE, args, NULL_TREE, NULL, - NULL, NULL_TREE, TRUE); + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE); } + #endif +/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ -/* ffecom_constantunion -- Transform constant-union to tree +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_assign (ffebld expr) +{ + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); +} - ffebldConstantUnion cu; // the constant to transform - ffeinfoBasictype bt; // its basic type - ffeinfoKindtype kt; // its kind type - tree tree_type; // ffecom_tree_type[bt][kt] - ffecom_constantunion(&cu,bt,kt,tree_type); */ +#endif +/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, - ffeinfoKindtype kt, tree tree_type) +ffecom_expr_assign_w (ffebld expr) { - tree item; - - switch (bt) - { - case FFEINFO_basictypeINTEGER: - { - int val; + return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); +} - switch (kt) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - val = ffebld_cu_val_integer1 (*cu); - break; #endif +/* Transform expr for use as into read/write tree and stabilize the + reference. Not for use on CHARACTER expressions. -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - val = ffebld_cu_val_integer2 (*cu); - break; -#endif + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - val = ffebld_cu_val_integer3 (*cu); - break; -#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_rw (tree type, ffebld expr) +{ + assert (expr != NULL); + /* Different target types not yet supported. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); + + return stabilize_reference (ffecom_expr (expr)); +} -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - val = ffebld_cu_val_integer4 (*cu); - break; #endif +/* Transform expr for use as into write tree and stabilize the + reference. Not for use on CHARACTER expressions. - default: - assert ("bad INTEGER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_int_2 (val, (val < 0) ? -1 : 0); - TREE_TYPE (item) = tree_type; - } - break; + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. */ - case FFEINFO_basictypeLOGICAL: - { - int val; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_expr_w (tree type, ffebld expr) +{ + assert (expr != NULL); + /* Different target types not yet supported. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); + + return stabilize_reference (ffecom_expr (expr)); +} - switch (kt) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - val = ffebld_cu_val_logical1 (*cu); - break; #endif +/* Do global stuff. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_compile () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + + ffeglobal_drive (ffecom_finish_global_); +} -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - val = ffebld_cu_val_logical2 (*cu); - break; #endif +/* Public entry point for front end to access finish_decl. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_decl (tree decl, tree init, bool is_top_level) +{ + assert (!is_top_level); + finish_decl (decl, init, FALSE); +} -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - val = ffebld_cu_val_logical3 (*cu); - break; #endif +/* Finish a program unit. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_progunit () +{ + ffecom_end_compstmt (); + + ffecom_previous_function_decl_ = current_function_decl; + ffecom_which_entrypoint_decl_ = NULL_TREE; + + finish_function (0); +} -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - val = ffebld_cu_val_logical4 (*cu); - break; #endif +/* Wrapper for get_identifier. pattern is sprintf-like, assumed to contain + one %s if text is not NULL, assumed to contain one %d if number is + not -1. If both are assumed, the %s is assumed to precede the %d. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_get_invented_identifier (const char *pattern, const char *text, + int number) +{ + tree decl; + char *nam; + mallocSize lenlen; + char space[66]; + + lenlen = 0; + if (text) + lenlen += strlen (text); + if (number != -1) + lenlen += 20; + if (text || number != -1) + { + lenlen += strlen (pattern); + if (lenlen > ARRAY_SIZE (space)) + nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen); + else + nam = &space[0]; + } + else + { + lenlen = 0; + nam = (char *) pattern; + } + + if (text == NULL) + { + if (number != -1) + sprintf (&nam[0], pattern, number); + } + else + { + if (number == -1) + sprintf (&nam[0], pattern, text); + else + sprintf (&nam[0], pattern, text, number); + } + + decl = get_identifier (nam); + + if (lenlen > ARRAY_SIZE (space)) + malloc_kill_ks (malloc_pool_image (), nam, lenlen); + + IDENTIFIER_INVENTED (decl) = 1; + + return decl; +} + +ffeinfoBasictype +ffecom_gfrt_basictype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + case FFECOM_rttypeVOIDSTAR_: + return FFEINFO_basictypeNONE; + + case FFECOM_rttypeFTNINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeINTEGER_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLONGINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLOGICAL_: + return FFEINFO_basictypeLOGICAL; + + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeDOUBLE_: + case FFECOM_rttypeDOUBLEREAL_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeCHARACTER_: + return FFEINFO_basictypeCHARACTER; + + default: + return FFEINFO_basictypeANY; + } +} + +ffeinfoKindtype +ffecom_gfrt_kindtype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + case FFECOM_rttypeVOIDSTAR_: + return FFEINFO_kindtypeNONE; - default: - assert ("bad LOGICAL constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_int_2 (val, (val < 0) ? -1 : 0); - TREE_TYPE (item) = tree_type; - } - break; + case FFECOM_rttypeFTNINT_: + return FFEINFO_kindtypeINTEGER1; - case FFEINFO_basictypeREAL: - { - REAL_VALUE_TYPE val; + case FFECOM_rttypeINTEGER_: + return FFEINFO_kindtypeINTEGER1; - switch (kt) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu)); - break; -#endif + case FFECOM_rttypeLONGINT_: + return FFEINFO_kindtypeINTEGER4; -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu)); - break; -#endif + case FFECOM_rttypeLOGICAL_: + return FFEINFO_kindtypeLOGICAL1; -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu)); - break; -#endif + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_kindtypeREAL1; -#if FFETARGET_okREAL4 - case FFEINFO_kindtypeREAL4: - val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu)); - break; -#endif + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_kindtypeREAL1; - default: - assert ("bad REAL constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_real (tree_type, val); - } - break; + case FFECOM_rttypeDOUBLE_: + case FFECOM_rttypeDOUBLEREAL_: + return FFEINFO_kindtypeREAL2; - case FFEINFO_basictypeCOMPLEX: - { - REAL_VALUE_TYPE real; - REAL_VALUE_TYPE imag; - tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_kindtypeREAL2; - switch (kt) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real); - imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary); - break; -#endif + case FFECOM_rttypeCHARACTER_: + return FFEINFO_kindtypeCHARACTER1; -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real); - imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary); - break; -#endif + default: + return FFEINFO_kindtypeANY; + } +} -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real); - imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary); - break; -#endif +void +ffecom_init_0 () +{ + tree endlink; + int i; + int j; + tree t; + tree field; + ffetype type; + ffetype base_type; -#if FFETARGET_okCOMPLEX4 - case FFEINFO_kindtypeREAL4: - real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real); - imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary); - break; -#endif + /* This block of code comes from the now-obsolete cktyps.c. It checks + whether the compiler environment is buggy in known ways, some of which + would, if not explicitly checked here, result in subtle bugs in g77. */ - default: - assert ("bad REAL constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = ffecom_build_complex_constant_ (tree_type, - build_real (el_type, real), - build_real (el_type, imag)); - } - break; + if (ffe_is_do_internal_checks ()) + { + static char names[][12] + = + {"bar", "bletch", "foo", "foobar"}; + char *name; + unsigned long ul; + double fl; - case FFEINFO_basictypeCHARACTER: - { /* Happens only in DATA and similar contexts. */ - ffetargetCharacter1 val; + name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), + (int (*)()) strcmp); + if (name != (char *) &names[2]) + { + assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h" + == NULL); + abort (); + } - switch (kt) - { -#if FFETARGET_okCHARACTER1 - case FFEINFO_kindtypeLOGICAL1: - val = ffebld_cu_val_character1 (*cu); - break; -#endif + ul = strtoul ("123456789", NULL, 10); + if (ul != 123456789L) + { + assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\ + in proj.h" == NULL); + abort (); + } - default: - assert ("bad CHARACTER constant kind type" == NULL); - /* Fall through. */ - case FFEINFO_kindtypeANY: - return error_mark_node; - } - item = build_string (ffetarget_length_character1 (val), - ffetarget_text_character1 (val)); - TREE_TYPE (item) - = build_type_variant (build_array_type (char_type_node, - build_range_type - (integer_type_node, - integer_one_node, - build_int_2 - (ffetarget_length_character1 - (val), 0))), - 1, 0); - } - break; + fl = atof ("56.789"); + if ((fl < 56.788) || (fl > 56.79)) + { + assert ("atof not type double, fix your #include " + == NULL); + abort (); + } + } - case FFEINFO_basictypeHOLLERITH: - { - ffetargetHollerith h; + /* Set the sizetype before we do anything else. This _should_ be the + first type we create. */ - h = ffebld_cu_val_hollerith (*cu); + t = make_unsigned_type (POINTER_SIZE); + assert (t == sizetype); - /* If not at least as wide as default INTEGER, widen it. */ - if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE) - item = build_string (h.length, h.text); - else - { - char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE]; +#if FFECOM_GCC_INCLUDE + ffecom_initialize_char_syntax_ (); +#endif - memcpy (str, h.text, h.length); - memset (&str[h.length], ' ', - FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE - - h.length); - item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE, - str); - } - TREE_TYPE (item) - = build_type_variant (build_array_type (char_type_node, - build_range_type - (integer_type_node, - integer_one_node, - build_int_2 - (h.length, 0))), - 1, 0); - } - break; + ffecom_outer_function_decl_ = NULL_TREE; + current_function_decl = NULL_TREE; + named_labels = NULL_TREE; + current_binding_level = NULL_BINDING_LEVEL; + free_binding_level = NULL_BINDING_LEVEL; + /* Make the binding_level structure for global names. */ + pushlevel (0); + global_binding_level = current_binding_level; + current_binding_level->prep_state = 2; - case FFEINFO_basictypeTYPELESS: - { - ffetargetInteger1 ival; - ffetargetTypeless tless; - ffebad error; + /* Define `int' and `char' first so that dbx will output them first. */ - tless = ffebld_cu_val_typeless (*cu); - error = ffetarget_convert_integer1_typeless (&ival, tless); - assert (error == FFEBAD); + integer_type_node = make_signed_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), + integer_type_node)); - item = build_int_2 ((int) ival, 0); - } - break; + char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), + char_type_node)); - default: - assert ("not yet on constant type" == NULL); - /* Fall through. */ - case FFEINFO_basictypeANY: - return error_mark_node; - } + long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), + long_integer_type_node)); - TREE_CONSTANT (item) = 1; + unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), + unsigned_type_node)); - return item; -} + long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), + long_unsigned_type_node)); -#endif + long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), + long_long_integer_type_node)); -/* Handy way to make a field in a struct/union. */ + long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), + long_long_unsigned_type_node)); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_decl_field (tree context, tree prevfield, - const char *name, tree type) -{ - tree field; + error_mark_node = make_node (ERROR_MARK); + TREE_TYPE (error_mark_node) = error_mark_node; - field = build_decl (FIELD_DECL, get_identifier (name), type); - DECL_CONTEXT (field) = context; - DECL_FRAME_SIZE (field) = 0; - if (prevfield != NULL_TREE) - TREE_CHAIN (prevfield) = field; + short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), + short_integer_type_node)); - return field; -} + short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), + short_unsigned_type_node)); -#endif + /* Define both `signed char' and `unsigned char'. */ + signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), + signed_char_type_node)); -void -ffecom_close_include (FILE *f) -{ -#if FFECOM_GCC_INCLUDE - ffecom_close_include_ (f); -#endif -} + unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), + unsigned_char_type_node)); -int -ffecom_decode_include_option (char *spec) -{ -#if FFECOM_GCC_INCLUDE - return ffecom_decode_include_option_ (spec); -#else - return 1; -#endif -} + float_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE; + layout_type (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), + float_type_node)); -/* ffecom_end_transition -- Perform end transition on all symbols + double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE; + layout_type (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), + double_type_node)); - ffecom_end_transition(); + long_double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE; + layout_type (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), + long_double_type_node)); - Calls ffecom_sym_end_transition for each global and local symbol. */ + complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), + complex_integer_type_node)); -void -ffecom_end_transition () -{ -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffebld item; -#endif + complex_float_type_node = ffecom_make_complex_type_ (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), + complex_float_type_node)); - if (ffe_is_ffedebug ()) - fprintf (dmpout, "; end_stmt_transition\n"); + complex_double_type_node = ffecom_make_complex_type_ (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), + complex_double_type_node)); -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffecom_list_blockdata_ = NULL; - ffecom_list_common_ = NULL; -#endif + complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), + complex_long_double_type_node)); - ffesymbol_drive (ffecom_sym_end_transition); - if (ffe_is_ffedebug ()) - { - ffestorag_report (); -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffesymbol_report_all (); -#endif - } + integer_zero_node = build_int_2 (0, 0); + TREE_TYPE (integer_zero_node) = integer_type_node; + integer_one_node = build_int_2 (1, 0); + TREE_TYPE (integer_one_node) = integer_type_node; -#if FFECOM_targetCURRENT == FFECOM_targetGCC - ffecom_start_progunit_ (); + size_zero_node = build_int_2 (0, 0); + TREE_TYPE (size_zero_node) = sizetype; + size_one_node = build_int_2 (1, 0); + TREE_TYPE (size_one_node) = sizetype; - for (item = ffecom_list_blockdata_; - item != NULL; - item = ffebld_trail (item)) - { - ffebld callee; - ffesymbol s; - tree dt; - tree t; - tree var; - int yes; - static int number = 0; + void_type_node = make_node (VOID_TYPE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), + void_type_node)); + layout_type (void_type_node); /* Uses integer_zero_node */ + /* We are not going to have real types in C with less than byte alignment, + so we might as well not have any types that claim to have it. */ + TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; - callee = ffebld_head (item); - s = ffebld_symter (callee); - t = ffesymbol_hook (s).decl_tree; - if (t == NULL_TREE) - { - s = ffecom_sym_transform_ (s); - t = ffesymbol_hook (s).decl_tree; - } + null_pointer_node = build_int_2 (0, 0); + TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node); + layout_type (TREE_TYPE (null_pointer_node)); - yes = suspend_momentary (); + string_type_node = build_pointer_type (char_type_node); - dt = build_pointer_type (TREE_TYPE (t)); + ffecom_tree_fun_type_void + = build_function_type (void_type_node, NULL_TREE); - var = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_forceload_%d", - NULL, number++), - dt); - DECL_EXTERNAL (var) = 0; - TREE_STATIC (var) = 1; - TREE_PUBLIC (var) = 0; - DECL_INITIAL (var) = error_mark_node; - TREE_USED (var) = 1; + ffecom_tree_ptr_to_fun_type_void + = build_pointer_type (ffecom_tree_fun_type_void); - var = start_decl (var, FALSE); + endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); - t = ffecom_1 (ADDR_EXPR, dt, t); + float_ftype_float + = build_function_type (float_type_node, + tree_cons (NULL_TREE, float_type_node, endlink)); - finish_decl (var, t, FALSE); + double_ftype_double + = build_function_type (double_type_node, + tree_cons (NULL_TREE, double_type_node, endlink)); - resume_momentary (yes); - } + ldouble_ftype_ldouble + = build_function_type (long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + endlink)); - /* This handles any COMMON areas that weren't referenced but have, for - example, important initial data. */ + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + ffecom_tree_type[i][j] = NULL_TREE; + ffecom_tree_fun_type[i][j] = NULL_TREE; + ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE; + ffecom_f2c_typecode_[i][j] = -1; + } - for (item = ffecom_list_common_; - item != NULL; - item = ffebld_trail (item)) - ffecom_transform_common_ (ffebld_symter (ffebld_head (item))); + /* Set up standard g77 types. Note that INTEGER and LOGICAL are set + to size FLOAT_TYPE_SIZE because they have to be the same size as + REAL, which also is FLOAT_TYPE_SIZE, according to the standard. + Compiler options and other such stuff that change the ways these + types are set should not affect this particular setup. */ - ffecom_list_common_ = NULL; -#endif -} + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger1)); -/* ffecom_exec_transition -- Perform exec transition on all symbols + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1] + = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"), + t)); - ffecom_exec_transition(); + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger2)); - Calls ffecom_sym_exec_transition for each global and local symbol. - Make sure error updating not inhibited. */ + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2] + = t = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("word"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger3)); -void -ffecom_exec_transition () -{ - bool inhibited; + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3] + = t = make_unsigned_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"), + t)); - if (ffe_is_ffedebug ()) - fprintf (dmpout, "; exec_stmt_transition\n"); + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger4)); - inhibited = ffebad_inhibit (); - ffebad_set_inhibit (FALSE); + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4] + = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"), + t)); - ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */ - ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */ - if (ffe_is_ffedebug ()) +#if 0 + if (ffe_is_do_internal_checks () + && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE + && LONG_TYPE_SIZE != CHAR_TYPE_SIZE + && LONG_TYPE_SIZE != SHORT_TYPE_SIZE + && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE) { - ffestorag_report (); -#if FFECOM_targetCURRENT == FFECOM_targetFFE - ffesymbol_report_all (); -#endif + fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n", + LONG_TYPE_SIZE); } +#endif - if (inhibited) - ffebad_set_inhibit (TRUE); -} - -/* ffecom_expand_let_stmt -- Compile let (assignment) statement - - ffebld dest; - ffebld source; - ffecom_expand_let_stmt(dest,source); + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical1)); - Convert dest and source using ffecom_expr, then join them - with an ASSIGN op and pass the whole thing to expand_expr_stmt. */ + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical2)); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_expand_let_stmt (ffebld dest, ffebld source) -{ - tree dest_tree; - tree dest_length; - tree source_tree; - tree expr_tree; + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical3)); - if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER) - { - bool dest_used; + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical4)); - dest_tree = ffecom_expr_rw (dest); - if (dest_tree == error_mark_node) - return; + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE; + pushdecl (build_decl (TYPE_DECL, get_identifier ("real"), + t)); + layout_type (t); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal1)); - if ((TREE_CODE (dest_tree) != VAR_DECL) - || TREE_ADDRESSABLE (dest_tree)) - source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used, - FALSE, FALSE); - else - { - source_tree = ffecom_expr (source); - dest_used = FALSE; - } - if (source_tree == error_mark_node) - return; + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"), + t)); + layout_type (t); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal2)); - if (dest_used) - expr_tree = source_tree; - else - expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, - dest_tree, - source_tree); + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex1)); - expand_expr_stmt (expr_tree); - return; - } + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, + type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex2)); - ffecom_push_calltemps (); - ffecom_char_args_ (&dest_tree, &dest_length, dest); - ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), - source); - ffecom_pop_calltemps (); -} + /* Make function and ptr-to-function types for non-CHARACTER types. */ -#endif -/* ffecom_expr -- Transform expr into gcc tree + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if ((t = ffecom_tree_type[i][j]) != NULL_TREE) + { + if (i == FFEINFO_basictypeINTEGER) + { + /* Figure out the smallest INTEGER type that can hold + a pointer on this machine. */ + if (GET_MODE_SIZE (TYPE_MODE (t)) + >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) + { + if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE) + || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_])) + > GET_MODE_SIZE (TYPE_MODE (t)))) + ffecom_pointer_kind_ = j; + } + } + else if (i == FFEINFO_basictypeCOMPLEX) + t = void_type_node; + /* For f2c compatibility, REAL functions are really + implemented as DOUBLE PRECISION. */ + else if ((i == FFEINFO_basictypeREAL) + && (j == FFEINFO_kindtypeREAL1)) + t = ffecom_tree_type + [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]; - tree t; - ffebld expr; // FFE expression. - tree = ffecom_expr(expr); + t = ffecom_tree_fun_type[i][j] = build_function_type (t, + NULL_TREE); + ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t); + } + } - Recursive descent on expr while making corresponding tree nodes and - attaching type info and such. */ + /* Set up pointer types. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_expr (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE); -} + if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE) + fatal ("no INTEGER type can hold a pointer on this configuration"); + else if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_); + ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT), + 7, + ffeinfo_type (FFEINFO_basictypeINTEGER, + ffecom_pointer_kind_)); -#endif -/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */ + if (ffe_is_ugly_assign ()) + ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */ + else + ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT; + if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_expr_assign (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} + ffecom_integer_type_node + = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]; + ffecom_integer_zero_node = convert (ffecom_integer_type_node, + integer_zero_node); + ffecom_integer_one_node = convert (ffecom_integer_type_node, + integer_one_node); -#endif -/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */ + /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional. + Turns out that by TYLONG, runtime/libI77/lio.h really means + "whatever size an ftnint is". For consistency and sanity, + com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen + all are INTEGER, which we also make out of whatever back-end + integer type is FLOAT_TYPE_SIZE bits wide. This change, from + LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to + accommodate machines like the Alpha. Note that this suggests + f2c and libf2c are missing a distinction perhaps needed on + some machines between "int" and "long int". -- burley 0.5.5 950215 */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_expr_assign_w (ffebld expr) -{ - return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE); -} + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLONG); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE, + FFETARGET_f2cTYSHORT); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE, + FFETARGET_f2cTYINT1); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL2); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL1); + /* ~~~Not really such a type in libf2c, e.g. I/O support? */ + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD); -#endif -/* Transform expr for use as into read/write tree and stabilize the - reference. Not for use on CHARACTER expressions. + /* CHARACTER stuff is all special-cased, so it is not handled in the above + loop. CHARACTER items are built as arrays of unsigned char. */ - Recursive descent on expr while making corresponding tree nodes and - attaching type info and such. */ + ffecom_tree_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = t = char_type_node; + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCHARACTER, + FFEINFO_kindtypeCHARACTER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) + == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0])); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_expr_rw (ffebld expr) -{ - assert (expr != NULL); + ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void; + ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] + = ffecom_tree_ptr_to_fun_type_void; + ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1] + = FFETARGET_f2cTYCHAR; - return stabilize_reference (ffecom_expr (expr)); -} + ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY] + = 0; -#endif -/* Do global stuff. */ + /* Make multi-return-value type and fields. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_finish_compile () -{ - assert (ffecom_outer_function_decl_ == NULL_TREE); - assert (current_function_decl == NULL_TREE); + ffecom_multi_type_node_ = make_node (UNION_TYPE); - ffeglobal_drive (ffecom_finish_global_); -} + field = NULL_TREE; -#endif -/* Public entry point for front end to access finish_decl. */ + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + char name[30]; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_finish_decl (tree decl, tree init, bool is_top_level) -{ - assert (!is_top_level); - finish_decl (decl, init, FALSE); -} + if (ffecom_tree_type[i][j] == NULL_TREE) + continue; /* Not supported. */ + sprintf (&name[0], "bt_%s_kt_%s", + ffeinfo_basictype_string ((ffeinfoBasictype) i), + ffeinfo_kindtype_string ((ffeinfoKindtype) j)); + ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL, + get_identifier (name), + ffecom_tree_type[i][j]); + DECL_CONTEXT (ffecom_multi_fields_[i][j]) + = ffecom_multi_type_node_; + DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0; + TREE_CHAIN (ffecom_multi_fields_[i][j]) = field; + field = ffecom_multi_fields_[i][j]; + } -#endif -/* Finish a program unit. */ + TYPE_FIELDS (ffecom_multi_type_node_) = field; + layout_type (ffecom_multi_type_node_); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_finish_progunit () -{ - ffecom_end_compstmt_ (); + /* Subroutines usually return integer because they might have alternate + returns. */ - ffecom_previous_function_decl_ = current_function_decl; - ffecom_which_entrypoint_decl_ = NULL_TREE; + ffecom_tree_subr_type + = build_function_type (integer_type_node, NULL_TREE); + ffecom_tree_ptr_to_subr_type + = build_pointer_type (ffecom_tree_subr_type); + ffecom_tree_blockdata_type + = build_function_type (void_type_node, NULL_TREE); - finish_function (0); -} + builtin_function ("__builtin_sqrtf", float_ftype_float, + BUILT_IN_FSQRT, "sqrtf"); + builtin_function ("__builtin_fsqrt", double_ftype_double, + BUILT_IN_FSQRT, "sqrt"); + builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, + BUILT_IN_FSQRT, "sqrtl"); + builtin_function ("__builtin_sinf", float_ftype_float, + BUILT_IN_SIN, "sinf"); + builtin_function ("__builtin_sin", double_ftype_double, + BUILT_IN_SIN, "sin"); + builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, + BUILT_IN_SIN, "sinl"); + builtin_function ("__builtin_cosf", float_ftype_float, + BUILT_IN_COS, "cosf"); + builtin_function ("__builtin_cos", double_ftype_double, + BUILT_IN_COS, "cos"); + builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, + BUILT_IN_COS, "cosl"); +#if BUILT_FOR_270 + pedantic_lvalues = FALSE; #endif -/* Wrapper for get_identifier. pattern is like "...%s...", text is - inserted into final name in place of "%s", or if text is NULL, - pattern is like "...%d..." and text form of number is inserted - in place of "%d". */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_get_invented_identifier (const char *pattern, const char *text, int number) -{ - tree decl; - char *nam; - mallocSize lenlen; - char space[66]; - - if (text == NULL) - lenlen = strlen (pattern) + 20; - else - lenlen = strlen (pattern) + strlen (text) - 1; - if (lenlen > ARRAY_SIZE (space)) - nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen); - else - nam = &space[0]; - if (text == NULL) - sprintf (&nam[0], pattern, number); - else - sprintf (&nam[0], pattern, text); - decl = get_identifier (nam); - if (lenlen > ARRAY_SIZE (space)) - malloc_kill_ks (malloc_pool_image (), nam, lenlen); - - IDENTIFIER_INVENTED (decl) = 1; - return decl; -} - -ffeinfoBasictype -ffecom_gfrt_basictype (ffecomGfrt gfrt) -{ - assert (gfrt < FFECOM_gfrt); - - switch (ffecom_gfrt_type_[gfrt]) - { - case FFECOM_rttypeVOID_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_basictypeNONE; + ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node, + FFECOM_f2cINTEGER, + "integer"); + ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node, + FFECOM_f2cADDRESS, + "address"); + ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node, + FFECOM_f2cREAL, + "real"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node, + FFECOM_f2cDOUBLEREAL, + "doublereal"); + ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node, + FFECOM_f2cCOMPLEX, + "complex"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node, + FFECOM_f2cDOUBLECOMPLEX, + "doublecomplex"); + ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node, + FFECOM_f2cLONGINT, + "longint"); + ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node, + FFECOM_f2cLOGICAL, + "logical"); + ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node, + FFECOM_f2cFLAG, + "flag"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node, + FFECOM_f2cFTNLEN, + "ftnlen"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node, + FFECOM_f2cFTNINT, + "ftnint"); - case FFECOM_rttypeFTNINT_: - return FFEINFO_basictypeINTEGER; + ffecom_f2c_ftnlen_zero_node + = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node); - case FFECOM_rttypeINTEGER_: - return FFEINFO_basictypeINTEGER; + ffecom_f2c_ftnlen_one_node + = convert (ffecom_f2c_ftnlen_type_node, integer_one_node); - case FFECOM_rttypeLONGINT_: - return FFEINFO_basictypeINTEGER; + ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0); + TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node; - case FFECOM_rttypeLOGICAL_: - return FFEINFO_basictypeLOGICAL; + ffecom_f2c_ptr_to_ftnlen_type_node + = build_pointer_type (ffecom_f2c_ftnlen_type_node); - case FFECOM_rttypeREAL_F2C_: - case FFECOM_rttypeREAL_GNU_: - return FFEINFO_basictypeREAL; + ffecom_f2c_ptr_to_ftnint_type_node + = build_pointer_type (ffecom_f2c_ftnint_type_node); - case FFECOM_rttypeCOMPLEX_F2C_: - case FFECOM_rttypeCOMPLEX_GNU_: - return FFEINFO_basictypeCOMPLEX; + ffecom_f2c_ptr_to_integer_type_node + = build_pointer_type (ffecom_f2c_integer_type_node); - case FFECOM_rttypeDOUBLE_: - case FFECOM_rttypeDOUBLEREAL_: - return FFEINFO_basictypeREAL; + ffecom_f2c_ptr_to_real_type_node + = build_pointer_type (ffecom_f2c_real_type_node); - case FFECOM_rttypeDBLCMPLX_F2C_: - case FFECOM_rttypeDBLCMPLX_GNU_: - return FFEINFO_basictypeCOMPLEX; + ffecom_float_zero_ = build_real (float_type_node, dconst0); + ffecom_double_zero_ = build_real (double_type_node, dconst0); + { + REAL_VALUE_TYPE point_5; - case FFECOM_rttypeCHARACTER_: - return FFEINFO_basictypeCHARACTER; +#ifdef REAL_ARITHMETIC + REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2); +#else + point_5 = .5; +#endif + ffecom_float_half_ = build_real (float_type_node, point_5); + ffecom_double_half_ = build_real (double_type_node, point_5); + } - default: - return FFEINFO_basictypeANY; - } -} + /* Do "extern int xargc;". */ -ffeinfoKindtype -ffecom_gfrt_kindtype (ffecomGfrt gfrt) -{ - assert (gfrt < FFECOM_gfrt); + ffecom_tree_xargc_ = build_decl (VAR_DECL, + get_identifier ("f__xargc"), + integer_type_node); + DECL_EXTERNAL (ffecom_tree_xargc_) = 1; + TREE_STATIC (ffecom_tree_xargc_) = 1; + TREE_PUBLIC (ffecom_tree_xargc_) = 1; + ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE); + finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE); - switch (ffecom_gfrt_type_[gfrt]) +#if 0 /* This is being fixed, and seems to be working now. */ + if ((FLOAT_TYPE_SIZE != 32) + || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32)) { - case FFECOM_rttypeVOID_: - case FFECOM_rttypeVOIDSTAR_: - return FFEINFO_kindtypeNONE; - - case FFECOM_rttypeFTNINT_: - return FFEINFO_kindtypeINTEGER1; + warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,", + (int) FLOAT_TYPE_SIZE); + warning ("and pointers are %d bits wide, but g77 doesn't yet work", + (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node)))); + warning ("properly unless they all are 32 bits wide."); + warning ("Please keep this in mind before you report bugs. g77 should"); + warning ("support non-32-bit machines better as of version 0.6."); + } +#endif - case FFECOM_rttypeINTEGER_: - return FFEINFO_kindtypeINTEGER1; +#if 0 /* Code in ste.c that would crash has been commented out. */ + if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) + < TYPE_PRECISION (string_type_node)) + /* I/O will probably crash. */ + warning ("configuration: char * holds %d bits, but ftnlen only %d", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)); +#endif - case FFECOM_rttypeLONGINT_: - return FFEINFO_kindtypeINTEGER4; +#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */ + if (TYPE_PRECISION (ffecom_integer_type_node) + < TYPE_PRECISION (string_type_node)) + /* ASSIGN 10 TO I will crash. */ + warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\ + ASSIGN statement might fail", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_integer_type_node)); +#endif +} - case FFECOM_rttypeLOGICAL_: - return FFEINFO_kindtypeLOGICAL1; +#endif +/* ffecom_init_2 -- Initialize - case FFECOM_rttypeREAL_F2C_: - case FFECOM_rttypeREAL_GNU_: - return FFEINFO_kindtypeREAL1; + ffecom_init_2(); */ - case FFECOM_rttypeCOMPLEX_F2C_: - case FFECOM_rttypeCOMPLEX_GNU_: - return FFEINFO_kindtypeREAL1; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_init_2 () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + assert (ffecom_which_entrypoint_decl_ == NULL_TREE); - case FFECOM_rttypeDOUBLE_: - case FFECOM_rttypeDOUBLEREAL_: - return FFEINFO_kindtypeREAL2; + ffecom_master_arglist_ = NULL; + ++ffecom_num_fns_; + ffecom_primary_entry_ = NULL; + ffecom_is_altreturning_ = FALSE; + ffecom_func_result_ = NULL_TREE; + ffecom_multi_retval_ = NULL_TREE; +} - case FFECOM_rttypeDBLCMPLX_F2C_: - case FFECOM_rttypeDBLCMPLX_GNU_: - return FFEINFO_kindtypeREAL2; +#endif +/* ffecom_list_expr -- Transform list of exprs into gcc tree - case FFECOM_rttypeCHARACTER_: - return FFEINFO_kindtypeCHARACTER1; + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_expr(expr); - default: - return FFEINFO_kindtypeANY; - } -} + List of actual args is transformed into corresponding gcc backend list. */ -void -ffecom_init_0 () +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_list_expr (ffebld expr) { - tree endlink; - int i; - int j; - tree t; - tree field; - ffetype type; - ffetype base_type; - - /* This block of code comes from the now-obsolete cktyps.c. It checks - whether the compiler environment is buggy in known ways, some of which - would, if not explicitly checked here, result in subtle bugs in g77. */ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; - if (ffe_is_do_internal_checks ()) + while (expr != NULL) { - static char names[][12] - = - {"bar", "bletch", "foo", "foobar"}; - char *name; - unsigned long ul; - double fl; - - name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), - (int (*)()) strcmp); - if (name != (char *) &names[2]) - { - assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h" - == NULL); - abort (); - } + tree texpr = ffecom_arg_expr (ffebld_head (expr), &length); - ul = strtoul ("123456789", NULL, 10); - if (ul != 123456789L) - { - assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\ - in proj.h" == NULL); - abort (); - } + if (texpr == error_mark_node) + return error_mark_node; - fl = atof ("56.789"); - if ((fl < 56.788) || (fl > 56.79)) + *plist = build_tree_list (NULL_TREE, texpr); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) { - assert ("atof not type double, fix your #include " - == NULL); - abort (); + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); } } - /* Set the sizetype before we do anything else. This _should_ be the - first type we create. */ - - t = make_unsigned_type (POINTER_SIZE); - assert (t == sizetype); - -#if FFECOM_GCC_INCLUDE - ffecom_initialize_char_syntax_ (); -#endif - - ffecom_outer_function_decl_ = NULL_TREE; - current_function_decl = NULL_TREE; - named_labels = NULL_TREE; - current_binding_level = NULL_BINDING_LEVEL; - free_binding_level = NULL_BINDING_LEVEL; - pushlevel (0); /* make the binding_level structure for - global names */ - global_binding_level = current_binding_level; - - /* Define `int' and `char' first so that dbx will output them first. */ - - integer_type_node = make_signed_type (INT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), - integer_type_node)); - - char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), - char_type_node)); - - long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), - long_integer_type_node)); - - unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), - unsigned_type_node)); + *plist = trail; - long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), - long_unsigned_type_node)); + return list; +} - long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), - long_long_integer_type_node)); +#endif +/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree - long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), - long_long_unsigned_type_node)); + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_ptr_to_expr(expr); - error_mark_node = make_node (ERROR_MARK); - TREE_TYPE (error_mark_node) = error_mark_node; + List of actual args is transformed into corresponding gcc backend list for + use in calling an external procedure (vs. a statement function). */ - short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), - short_integer_type_node)); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_list_ptr_to_expr (ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; - short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), - short_unsigned_type_node)); + while (expr != NULL) + { + tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length); - /* Define both `signed char' and `unsigned char'. */ - signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), - signed_char_type_node)); + if (texpr == error_mark_node) + return error_mark_node; - unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), - unsigned_char_type_node)); + *plist = build_tree_list (NULL_TREE, texpr); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } - float_type_node = make_node (REAL_TYPE); - TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE; - layout_type (float_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), - float_type_node)); + *plist = trail; - double_type_node = make_node (REAL_TYPE); - TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE; - layout_type (double_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), - double_type_node)); + return list; +} - long_double_type_node = make_node (REAL_TYPE); - TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE; - layout_type (long_double_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), - long_double_type_node)); +#endif +/* Obtain gcc's LABEL_DECL tree for label. */ - complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), - complex_integer_type_node)); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_lookup_label (ffelab label) +{ + tree glabel; - complex_float_type_node = ffecom_make_complex_type_ (float_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), - complex_float_type_node)); + if (ffelab_hook (label) == NULL_TREE) + { + char labelname[16]; - complex_double_type_node = ffecom_make_complex_type_ (double_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), - complex_double_type_node)); + switch (ffelab_type (label)) + { + case FFELAB_typeLOOPEND: + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label)); + glabel = build_decl (LABEL_DECL, get_identifier (labelname), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + break; - complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), - complex_long_double_type_node)); + case FFELAB_typeFORMAT: + push_obstacks_nochange (); + end_temporary_allocation (); - integer_zero_node = build_int_2 (0, 0); - TREE_TYPE (integer_zero_node) = integer_type_node; - integer_one_node = build_int_2 (1, 0); - TREE_TYPE (integer_one_node) = integer_type_node; + glabel = build_decl (VAR_DECL, + ffecom_get_invented_identifier + ("__g77_format_%d", NULL, + (int) ffelab_value (label)), + build_type_variant (build_array_type + (char_type_node, + NULL_TREE), + 1, 0)); + TREE_CONSTANT (glabel) = 1; + TREE_STATIC (glabel) = 1; + DECL_CONTEXT (glabel) = 0; + DECL_INITIAL (glabel) = NULL; + make_decl_rtl (glabel, NULL, 0); + expand_decl (glabel); - size_zero_node = build_int_2 (0, 0); - TREE_TYPE (size_zero_node) = sizetype; - size_one_node = build_int_2 (1, 0); - TREE_TYPE (size_one_node) = sizetype; + resume_temporary_allocation (); + pop_obstacks (); - void_type_node = make_node (VOID_TYPE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), - void_type_node)); - layout_type (void_type_node); /* Uses integer_zero_node */ - /* We are not going to have real types in C with less than byte alignment, - so we might as well not have any types that claim to have it. */ - TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; + break; - null_pointer_node = build_int_2 (0, 0); - TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node); - layout_type (TREE_TYPE (null_pointer_node)); + case FFELAB_typeANY: + glabel = error_mark_node; + break; - string_type_node = build_pointer_type (char_type_node); + default: + assert ("bad label type" == NULL); + glabel = NULL; + break; + } + ffelab_set_hook (label, glabel); + } + else + { + glabel = ffelab_hook (label); + } - ffecom_tree_fun_type_void - = build_function_type (void_type_node, NULL_TREE); + return glabel; +} - ffecom_tree_ptr_to_fun_type_void - = build_pointer_type (ffecom_tree_fun_type_void); +#endif +/* Stabilizes the arguments. Don't use this if the lhs and rhs come from + a single source specification (as in the fourth argument of MVBITS). + If the type is NULL_TREE, the type of lhs is used to make the type of + the MODIFY_EXPR. */ - endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_modify (tree newtype, tree lhs, + tree rhs) +{ + if (lhs == error_mark_node || rhs == error_mark_node) + return error_mark_node; - float_ftype_float - = build_function_type (float_type_node, - tree_cons (NULL_TREE, float_type_node, endlink)); + if (newtype == NULL_TREE) + newtype = TREE_TYPE (lhs); - double_ftype_double - = build_function_type (double_type_node, - tree_cons (NULL_TREE, double_type_node, endlink)); + if (TREE_SIDE_EFFECTS (lhs)) + lhs = stabilize_reference (lhs); - ldouble_ftype_ldouble - = build_function_type (long_double_type_node, - tree_cons (NULL_TREE, long_double_type_node, - endlink)); + return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs); +} - for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) - for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) - { - ffecom_tree_type[i][j] = NULL_TREE; - ffecom_tree_fun_type[i][j] = NULL_TREE; - ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE; - ffecom_f2c_typecode_[i][j] = -1; - } +#endif - /* Set up standard g77 types. Note that INTEGER and LOGICAL are set - to size FLOAT_TYPE_SIZE because they have to be the same size as - REAL, which also is FLOAT_TYPE_SIZE, according to the standard. - Compiler options and other such stuff that change the ways these - types are set should not affect this particular setup. */ +/* Register source file name. */ - ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1] - = t = make_signed_type (FLOAT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"), - t)); - type = ffetype_new (); - base_type = type; - ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 1, type); - assert (ffetype_size (type) == sizeof (ffetargetInteger1)); +void +ffecom_file (char *name) +{ +#if FFECOM_GCC_INCLUDE + ffecom_file_ (name); +#endif +} - ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1] - = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"), - t)); +/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed - ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2] - = t = make_signed_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 3, type); - assert (ffetype_size (type) == sizeof (ffetargetInteger2)); + ffestorag st; + ffecom_notify_init_storage(st); - ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2] - = t = make_unsigned_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"), - t)); + Gets called when all possible units in an aggregate storage area (a LOCAL + with equivalences or a COMMON) have been initialized. The initialization + info either is in ffestorag_init or, if that is NULL, + ffestorag_accretion: - ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3] - = t = make_signed_type (CHAR_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("word"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 6, type); - assert (ffetype_size (type) == sizeof (ffetargetInteger3)); + ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! - ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3] - = t = make_unsigned_type (CHAR_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"), - t)); + ffestorag_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. - ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4] - = t = make_signed_type (FLOAT_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 2, type); - assert (ffetype_size (type) == sizeof (ffetargetInteger4)); + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. - ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4] - = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"), - t)); + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ -#if 0 - if (ffe_is_do_internal_checks () - && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE - && LONG_TYPE_SIZE != CHAR_TYPE_SIZE - && LONG_TYPE_SIZE != SHORT_TYPE_SIZE - && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE) +void +ffecom_notify_init_storage (ffestorag st) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ + ffetargetAlign pad; /* Its initial padding. */ +#endif + + if (ffestorag_init (st) == NULL) { - fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n", - LONG_TYPE_SIZE); + init = ffestorag_accretion (st); + assert (init != NULL); + ffestorag_set_accretion (st, NULL); + ffestorag_set_accretes (st, 0); + +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ + size = ffebld_accter_size (init); + pad = ffebld_accter_pad (init); + ffebit_kill (ffebld_accter_bits (init)); + ffebld_set_op (init, FFEBLD_opARRTER); + ffebld_set_arrter (init, ffebld_accter (init)); + ffebld_arrter_set_size (init, size); + ffebld_arrter_set_pad (init, size); +#endif + +#if FFECOM_TWOPASS + ffestorag_set_init (st, init); +#endif } +#if FFECOM_ONEPASS + else + init = ffestorag_init (st); #endif - ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1] - = t = make_signed_type (FLOAT_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"), - t)); - type = ffetype_new (); - base_type = type; - ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 1, type); - assert (ffetype_size (type) == sizeof (ffetargetLogical1)); +#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */ + ffestorag_set_init (st, ffebld_new_any ()); - ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2] - = t = make_signed_type (CHAR_TYPE_SIZE); - pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 3, type); - assert (ffetype_size (type) == sizeof (ffetargetLogical2)); + if (ffebld_op (init) == FFEBLD_opANY) + return; /* Oh, we already did this! */ - ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3] - = t = make_signed_type (CHAR_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 6, type); - assert (ffetype_size (type) == sizeof (ffetargetLogical3)); +#if FFECOM_targetCURRENT == FFECOM_targetFFE + { + ffesymbol s; - ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4] - = t = make_signed_type (FLOAT_TYPE_SIZE * 2); - pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 2, type); - assert (ffetype_size (type) == sizeof (ffetargetLogical4)); + if (ffestorag_symbol (st) != NULL) + s = ffestorag_symbol (st); + else + s = ffestorag_typesymbol (st); - ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] - = t = make_node (REAL_TYPE); - TYPE_PRECISION (t) = FLOAT_TYPE_SIZE; - pushdecl (build_decl (TYPE_DECL, get_identifier ("real"), - t)); - layout_type (t); - type = ffetype_new (); - base_type = type; - ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 1, type); - ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] - = FFETARGET_f2cTYREAL; - assert (ffetype_size (type) == sizeof (ffetargetReal1)); + fprintf (dmpout, "= initialize_storage \"%s\" ", + (s != NULL) ? ffesymbol_text (s) : "(unnamed)"); + ffebld_dump (init); + fputc ('\n', dmpout); + } +#endif - ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE] - = t = make_node (REAL_TYPE); - TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */ - pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"), - t)); - layout_type (t); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 2, type); - ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2] - = FFETARGET_f2cTYDREAL; - assert (ffetype_size (type) == sizeof (ffetargetReal2)); +#endif /* if FFECOM_ONEPASS */ +} - ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] - = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]); - pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"), - t)); - type = ffetype_new (); - base_type = type; - ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 1, type); - ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] - = FFETARGET_f2cTYCOMPLEX; - assert (ffetype_size (type) == sizeof (ffetargetComplex1)); +/* ffecom_notify_init_symbol -- A symbol is now fully init'ed - ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE] - = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]); - pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"), - t)); - type = ffetype_new (); - ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_star (base_type, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, - type); - ffetype_set_kind (base_type, 2, - type); - ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2] - = FFETARGET_f2cTYDCOMPLEX; - assert (ffetype_size (type) == sizeof (ffetargetComplex2)); + ffesymbol s; + ffecom_notify_init_symbol(s); - /* Make function and ptr-to-function types for non-CHARACTER types. */ + Gets called when all possible units in a symbol (not placed in COMMON + or involved in EQUIVALENCE, unless it as yet has no ffestorag object) + have been initialized. The initialization info either is in + ffesymbol_init or, if that is NULL, ffesymbol_accretion: - for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) - for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) - { - if ((t = ffecom_tree_type[i][j]) != NULL_TREE) - { - if (i == FFEINFO_basictypeINTEGER) - { - /* Figure out the smallest INTEGER type that can hold - a pointer on this machine. */ - if (GET_MODE_SIZE (TYPE_MODE (t)) - >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) - { - if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE) - || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_])) - > GET_MODE_SIZE (TYPE_MODE (t)))) - ffecom_pointer_kind_ = j; - } - } - else if (i == FFEINFO_basictypeCOMPLEX) - t = void_type_node; - /* For f2c compatibility, REAL functions are really - implemented as DOUBLE PRECISION. */ - else if ((i == FFEINFO_basictypeREAL) - && (j == FFEINFO_kindtypeREAL1)) - t = ffecom_tree_type - [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]; + ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! - t = ffecom_tree_fun_type[i][j] = build_function_type (t, - NULL_TREE); - ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t); - } - } + ffesymbol_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. - /* Set up pointer types. */ + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. - if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE) - fatal ("no INTEGER type can hold a pointer on this configuration"); - else if (0 && ffe_is_do_internal_checks ()) - fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_); - ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT), - 7, - ffeinfo_type (FFEINFO_basictypeINTEGER, - ffecom_pointer_kind_)); + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ - if (ffe_is_ugly_assign ()) - ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */ - else - ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT; - if (0 && ffe_is_do_internal_checks ()) - fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_); +void +ffecom_notify_init_symbol (ffesymbol s) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ + ffetargetAlign pad; /* Its initial padding. */ +#endif - ffecom_integer_type_node - = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]; - ffecom_integer_zero_node = convert (ffecom_integer_type_node, - integer_zero_node); - ffecom_integer_one_node = convert (ffecom_integer_type_node, - integer_one_node); + if (ffesymbol_storage (s) == NULL) + return; /* Do nothing until COMMON/EQUIVALENCE + possibilities checked. */ - /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional. - Turns out that by TYLONG, runtime/libI77/lio.h really means - "whatever size an ftnint is". For consistency and sanity, - com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen - all are INTEGER, which we also make out of whatever back-end - integer type is FLOAT_TYPE_SIZE bits wide. This change, from - LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to - accommodate machines like the Alpha. Note that this suggests - f2c and libf2c are missing a distinction perhaps needed on - some machines between "int" and "long int". -- burley 0.5.5 950215 */ + if ((ffesymbol_init (s) == NULL) + && ((init = ffesymbol_accretion (s)) != NULL)) + { + ffesymbol_set_accretion (s, NULL); + ffesymbol_set_accretes (s, 0); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE, - FFETARGET_f2cTYLONG); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE, - FFETARGET_f2cTYSHORT); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE, - FFETARGET_f2cTYINT1); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE, - FFETARGET_f2cTYQUAD); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE, - FFETARGET_f2cTYLOGICAL); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE, - FFETARGET_f2cTYLOGICAL2); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE, - FFETARGET_f2cTYLOGICAL1); - ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE, - FFETARGET_f2cTYQUAD /* ~~~ */); +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ + size = ffebld_accter_size (init); + pad = ffebld_accter_pad (init); + ffebit_kill (ffebld_accter_bits (init)); + ffebld_set_op (init, FFEBLD_opARRTER); + ffebld_set_arrter (init, ffebld_accter (init)); + ffebld_arrter_set_size (init, size); + ffebld_arrter_set_pad (init, size); +#endif - /* CHARACTER stuff is all special-cased, so it is not handled in the above - loop. CHARACTER items are built as arrays of unsigned char. */ +#if FFECOM_TWOPASS + ffesymbol_set_init (s, init); +#endif + } +#if FFECOM_ONEPASS + else + init = ffesymbol_init (s); +#endif - ffecom_tree_type[FFEINFO_basictypeCHARACTER] - [FFEINFO_kindtypeCHARACTER1] = t = char_type_node; - type = ffetype_new (); - base_type = type; - ffeinfo_set_type (FFEINFO_basictypeCHARACTER, - FFEINFO_kindtypeCHARACTER1, - type); - ffetype_set_ams (type, - TYPE_ALIGN (t) / BITS_PER_UNIT, 0, - TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); - ffetype_set_kind (base_type, 1, type); - assert (ffetype_size (type) - == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0])); +#if FFECOM_ONEPASS + ffesymbol_set_init (s, ffebld_new_any ()); - ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER] - [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void; - ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER] - [FFEINFO_kindtypeCHARACTER1] - = ffecom_tree_ptr_to_fun_type_void; - ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1] - = FFETARGET_f2cTYCHAR; + if (ffebld_op (init) == FFEBLD_opANY) + return; /* Oh, we already did this! */ - ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY] - = 0; +#if FFECOM_targetCURRENT == FFECOM_targetFFE + fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s)); + ffebld_dump (init); + fputc ('\n', dmpout); +#endif - /* Make multi-return-value type and fields. */ +#endif /* if FFECOM_ONEPASS */ +} - ffecom_multi_type_node_ = make_node (UNION_TYPE); +/* ffecom_notify_primary_entry -- Learn which is the primary entry point - field = NULL_TREE; + ffesymbol s; + ffecom_notify_primary_entry(s); - for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) - for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) - { - char name[30]; + Gets called when implicit or explicit PROGRAM statement seen or when + FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary + global symbol that serves as the entry point. */ - if (ffecom_tree_type[i][j] == NULL_TREE) - continue; /* Not supported. */ - sprintf (&name[0], "bt_%s_kt_%s", - ffeinfo_basictype_string ((ffeinfoBasictype) i), - ffeinfo_kindtype_string ((ffeinfoKindtype) j)); - ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL, - get_identifier (name), - ffecom_tree_type[i][j]); - DECL_CONTEXT (ffecom_multi_fields_[i][j]) - = ffecom_multi_type_node_; - DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0; - TREE_CHAIN (ffecom_multi_fields_[i][j]) = field; - field = ffecom_multi_fields_[i][j]; - } +void +ffecom_notify_primary_entry (ffesymbol s) +{ + ffecom_primary_entry_ = s; + ffecom_primary_entry_kind_ = ffesymbol_kind (s); - TYPE_FIELDS (ffecom_multi_type_node_) = field; - layout_type (ffecom_multi_type_node_); + if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)) + ffecom_primary_entry_is_proc_ = TRUE; + else + ffecom_primary_entry_is_proc_ = FALSE; - /* Subroutines usually return integer because they might have alternate - returns. */ + if (!ffe_is_silent ()) + { + if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM) + fprintf (stderr, "%s:\n", ffesymbol_text (s)); + else + fprintf (stderr, " %s:\n", ffesymbol_text (s)); + } - ffecom_tree_subr_type - = build_function_type (integer_type_node, NULL_TREE); - ffecom_tree_ptr_to_subr_type - = build_pointer_type (ffecom_tree_subr_type); - ffecom_tree_blockdata_type - = build_function_type (void_type_node, NULL_TREE); +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) + { + ffebld list; + ffebld arg; - builtin_function ("__builtin_sqrtf", float_ftype_float, - BUILT_IN_FSQRT, "sqrtf"); - builtin_function ("__builtin_fsqrt", double_ftype_double, - BUILT_IN_FSQRT, "sqrt"); - builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, - BUILT_IN_FSQRT, "sqrtl"); - builtin_function ("__builtin_sinf", float_ftype_float, - BUILT_IN_SIN, "sinf"); - builtin_function ("__builtin_sin", double_ftype_double, - BUILT_IN_SIN, "sin"); - builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, - BUILT_IN_SIN, "sinl"); - builtin_function ("__builtin_cosf", float_ftype_float, - BUILT_IN_COS, "cosf"); - builtin_function ("__builtin_cos", double_ftype_double, - BUILT_IN_COS, "cos"); - builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, - BUILT_IN_COS, "cosl"); + for (list = ffesymbol_dummyargs (s); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } +#endif +} -#if BUILT_FOR_270 - pedantic_lvalues = FALSE; +FILE * +ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) +{ +#if FFECOM_GCC_INCLUDE + return ffecom_open_include_ (name, l, c); +#else + return fopen (name, "r"); #endif +} - ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node, - FFECOM_f2cINTEGER, - "integer"); - ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node, - FFECOM_f2cADDRESS, - "address"); - ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node, - FFECOM_f2cREAL, - "real"); - ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node, - FFECOM_f2cDOUBLEREAL, - "doublereal"); - ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node, - FFECOM_f2cCOMPLEX, - "complex"); - ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node, - FFECOM_f2cDOUBLECOMPLEX, - "doublecomplex"); - ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node, - FFECOM_f2cLONGINT, - "longint"); - ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node, - FFECOM_f2cLOGICAL, - "logical"); - ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node, - FFECOM_f2cFLAG, - "flag"); - ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node, - FFECOM_f2cFTNLEN, - "ftnlen"); - ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node, - FFECOM_f2cFTNINT, - "ftnint"); +/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front - ffecom_f2c_ftnlen_zero_node - = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node); + tree t; + ffebld expr; // FFE expression. + tree = ffecom_ptr_to_expr(expr); - ffecom_f2c_ftnlen_one_node - = convert (ffecom_f2c_ftnlen_type_node, integer_one_node); + Like ffecom_expr, but sticks address-of in front of most things. */ - ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0); - TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node; +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_ptr_to_expr (ffebld expr) +{ + tree item; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffesymbol s; - ffecom_f2c_ptr_to_ftnlen_type_node - = build_pointer_type (ffecom_f2c_ftnlen_type_node); + assert (expr != NULL); - ffecom_f2c_ptr_to_ftnint_type_node - = build_pointer_type (ffecom_f2c_ftnint_type_node); + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + ffecomGfrt ix; - ffecom_f2c_ptr_to_integer_type_node - = build_pointer_type (ffecom_f2c_integer_type_node); + ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr)); + assert (ix != FFECOM_gfrt); + if ((item = ffecom_gfrt_[ix]) == NULL_TREE) + { + ffecom_make_gfrt_ (ix); + item = ffecom_gfrt_[ix]; + } + } + else + { + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + } + assert (item != NULL); + if (item == error_mark_node) + return item; + if (!ffesymbol_hook (s).addr) + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; - ffecom_f2c_ptr_to_real_type_node - = build_pointer_type (ffecom_f2c_real_type_node); + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; + tree array; + int i; - ffecom_float_zero_ = build_real (float_type_node, dconst0); - ffecom_double_zero_ = build_real (double_type_node, dconst0); - { - REAL_VALUE_TYPE point_5; + item = ffecom_ptr_to_expr (ffebld_left (expr)); -#ifdef REAL_ARITHMETIC - REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2); -#else - point_5 = .5; -#endif - ffecom_float_half_ = build_real (float_type_node, point_5); - ffecom_double_half_ = build_real (double_type_node, point_5); - } + if (item == error_mark_node) + return item; - /* Do "extern int xargc;". */ + if ((ffebld_where (expr) == FFEINFO_whereFLEETING) + && !mark_addressable (item)) + return error_mark_node; /* Make sure non-const ref is to + non-reg. */ - ffecom_tree_xargc_ = build_decl (VAR_DECL, - get_identifier ("f__xargc"), - integer_type_node); - DECL_EXTERNAL (ffecom_tree_xargc_) = 1; - TREE_STATIC (ffecom_tree_xargc_) = 1; - TREE_PUBLIC (ffecom_tree_xargc_) = 1; - ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE); - finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE); + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ -#if 0 /* This is being fixed, and seems to be working now. */ - if ((FLOAT_TYPE_SIZE != 32) - || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32)) - { - warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,", - (int) FLOAT_TYPE_SIZE); - warning ("and pointers are %d bits wide, but g77 doesn't yet work", - (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node)))); - warning ("properly unless they all are 32 bits wide."); - warning ("Please keep this in mind before you report bugs. g77 should"); - warning ("support non-32-bit machines better as of version 0.6."); - } -#endif + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); -#if 0 /* Code in ste.c that would crash has been commented out. */ - if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) - < TYPE_PRECISION (string_type_node)) - /* I/O will probably crash. */ - warning ("configuration: char * holds %d bits, but ftnlen only %d", - TYPE_PRECISION (string_type_node), - TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)); -#endif + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + { + /* The initial subtraction should happen in the original type so + that (possible) negative values are handled appropriately. */ + item + = ffecom_2 (PLUS_EXPR, + build_pointer_type (TREE_TYPE (array)), + item, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + convert (sizetype, + fold (build (MINUS_EXPR, + TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))), + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))))); + } + } + return item; -#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */ - if (TYPE_PRECISION (ffecom_integer_type_node) - < TYPE_PRECISION (string_type_node)) - /* ASSIGN 10 TO I will crash. */ - warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\ - ASSIGN statement might fail", - TYPE_PRECISION (string_type_node), - TYPE_PRECISION (ffecom_integer_type_node)); -#endif -} + case FFEBLD_opCONTER: -#endif -/* ffecom_init_2 -- Initialize + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); - ffecom_init_2(); */ + item = ffecom_constantunion (&ffebld_constant_union + (ffebld_conter (expr)), bt, kt, + ffecom_tree_type[bt][kt]); + if (item == error_mark_node) + return error_mark_node; + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_init_2 () -{ - assert (ffecom_outer_function_decl_ == NULL_TREE); - assert (current_function_decl == NULL_TREE); - assert (ffecom_which_entrypoint_decl_ == NULL_TREE); + case FFEBLD_opANY: + return error_mark_node; - ffecom_master_arglist_ = NULL; - ++ffecom_num_fns_; - ffecom_latest_temp_ = NULL; - ffecom_primary_entry_ = NULL; - ffecom_is_altreturning_ = FALSE; - ffecom_func_result_ = NULL_TREE; - ffecom_multi_retval_ = NULL_TREE; + default: + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + item = ffecom_expr (expr); + if (item == error_mark_node) + return error_mark_node; + + /* The back end currently optimizes a bit too zealously for us, in that + we fail JCB001 if the following block of code is omitted. It checks + to see if the transformed expression is a symbol or array reference, + and encloses it in a SAVE_EXPR if that is the case. */ + + STRIP_NOPS (item); + if ((TREE_CODE (item) == VAR_DECL) + || (TREE_CODE (item) == PARM_DECL) + || (TREE_CODE (item) == RESULT_DECL) + || (TREE_CODE (item) == INDIRECT_REF) + || (TREE_CODE (item) == ARRAY_REF) + || (TREE_CODE (item) == COMPONENT_REF) +#ifdef OFFSET_REF + || (TREE_CODE (item) == OFFSET_REF) +#endif + || (TREE_CODE (item) == BUFFER_REF) + || (TREE_CODE (item) == REALPART_EXPR) + || (TREE_CODE (item) == IMAGPART_EXPR)) + { + item = ffecom_save_tree (item); + } + + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + } + + assert ("fall-through error" == NULL); + return error_mark_node; } #endif -/* ffecom_list_expr -- Transform list of exprs into gcc tree +/* Obtain a temp var with given data type. - tree t; - ffebld expr; // FFE opITEM list. - tree = ffecom_list_expr(expr); + size is FFETARGET_charactersizeNONE for a non-CHARACTER type + or >= 0 for a CHARACTER type. - List of actual args is transformed into corresponding gcc backend list. */ + elements is -1 for a scalar or > 0 for an array of type. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_list_expr (ffebld expr) +ffecom_make_tempvar (const char *commentary, tree type, + ffetargetCharacterSize size, int elements) { - tree list; - tree *plist = &list; - tree trail = NULL_TREE; /* Append char length args here. */ - tree *ptrail = &trail; - tree length; + int yes; + tree t; + static int mynumber; - while (expr != NULL) - { - tree texpr = ffecom_arg_expr (ffebld_head (expr), &length); + assert (current_binding_level->prep_state < 2); - if (texpr == error_mark_node) - return error_mark_node; + if (type == error_mark_node) + return error_mark_node; - *plist = build_tree_list (NULL_TREE, texpr); - plist = &TREE_CHAIN (*plist); - expr = ffebld_trail (expr); - if (length != NULL_TREE) - { - *ptrail = build_tree_list (NULL_TREE, length); - ptrail = &TREE_CHAIN (*ptrail); - } - } + yes = suspend_momentary (); - *plist = trail; + if (size != FFETARGET_charactersizeNONE) + type = build_array_type (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + build_int_2 (size, 0))); + if (elements != -1) + type = build_array_type (type, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 (elements - 1, + 0))); + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_%s_%d", + commentary, + mynumber++), + type); - return list; -} + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + resume_momentary (yes); + return t; +} #endif -/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree - tree t; - ffebld expr; // FFE opITEM list. - tree = ffecom_list_ptr_to_expr(expr); +/* Prepare argument pointer to expression. - List of actual args is transformed into corresponding gcc backend list for - use in calling an external procedure (vs. a statement function). */ + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_arg_ptr_to_expr. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_list_ptr_to_expr (ffebld expr) +void +ffecom_prepare_arg_ptr_to_expr (ffebld expr) { - tree list; - tree *plist = &list; - tree trail = NULL_TREE; /* Append char length args here. */ - tree *ptrail = &trail; - tree length; - - while (expr != NULL) - { - tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length); + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} - if (texpr == error_mark_node) - return error_mark_node; +/* End of preparations. */ - *plist = build_tree_list (NULL_TREE, texpr); - plist = &TREE_CHAIN (*plist); - expr = ffebld_trail (expr); - if (length != NULL_TREE) - { - *ptrail = build_tree_list (NULL_TREE, length); - ptrail = &TREE_CHAIN (*ptrail); - } - } +bool +ffecom_prepare_end (void) +{ + int prep_state = current_binding_level->prep_state; - *plist = trail; + assert (prep_state < 2); + current_binding_level->prep_state = 2; - return list; + return (prep_state == 1) ? TRUE : FALSE; } -#endif -/* Obtain gcc's LABEL_DECL tree for label. */ +/* Prepare expression. -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_lookup_label (ffelab label) + This is called before any code is generated for the current block. + It scans the expression, declares any temporaries that might be needed + during evaluation of the expression, and stores those temporaries in + the appropriate "hook" fields of the expression. `dest', if not NULL, + specifies the destination that ffecom_expr_ will see, in case that + helps avoid generating unused temporaries. + + ~~Improve to avoid allocating unused temporaries by taking `dest' + into account vis-a-vis aliasing requirements of complex/character + functions. */ + +void +ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) { - tree glabel; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize sz; + tree tempvar = NULL_TREE; - if (ffelab_hook (label) == NULL_TREE) + assert (current_binding_level->prep_state < 2); + + if (! expr) + return; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + sz = ffeinfo_size (ffebld_info (expr)); + + /* Generate whatever temporaries are needed to represent the result + of the expression. */ + + switch (ffebld_op (expr)) { - char labelname[16]; + default: + /* Don't make temps for SYMTER, CONTER, etc. */ + if (ffebld_arity (expr) == 0) + break; - switch (ffelab_type (label)) + switch (bt) { - case FFELAB_typeLOOPEND: - case FFELAB_typeNOTLOOP: - case FFELAB_typeENDIF: - sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label)); - glabel = build_decl (LABEL_DECL, get_identifier (labelname), - void_type_node); - DECL_CONTEXT (glabel) = current_function_decl; - DECL_MODE (glabel) = VOIDmode; - break; - - case FFELAB_typeFORMAT: - push_obstacks_nochange (); - end_temporary_allocation (); + case FFEINFO_basictypeCOMPLEX: + if (ffebld_op (expr) == FFEBLD_opFUNCREF) + { + ffesymbol s; - glabel = build_decl (VAR_DECL, - ffecom_get_invented_identifier - ("__g77_format_%d", NULL, - (int) ffelab_value (label)), - build_type_variant (build_array_type - (char_type_node, - NULL_TREE), - 1, 0)); - TREE_CONSTANT (glabel) = 1; - TREE_STATIC (glabel) = 1; - DECL_CONTEXT (glabel) = 0; - DECL_INITIAL (glabel) = NULL; - make_decl_rtl (glabel, NULL, 0); - expand_decl (glabel); + if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER) + break; - resume_temporary_allocation (); - pop_obstacks (); + s = ffebld_symter (ffebld_left (expr)); + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT + || ! ffesymbol_is_f2c (s)) + break; + } + else if (ffebld_op (expr) == FFEBLD_opPOWER) + { + /* Requires special treatment. There's no POW_CC function + in libg2c, so POW_ZZ is used, which means we always + need a double-complex temp, not a single-complex. */ + kt = FFEINFO_kindtypeREAL2; + } + else if (ffebld_op (expr) != FFEBLD_opDIVIDE) + /* The other ops don't need temps for complex operands. */ + break; + /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C), + REAL(C). See 19990325-0.f, routine `check', for cases. */ + tempvar = ffecom_make_tempvar ("complex", + ffecom_tree_type + [FFEINFO_basictypeCOMPLEX][kt], + FFETARGET_charactersizeNONE, + -1); break; - case FFELAB_typeANY: - glabel = error_mark_node; + case FFEINFO_basictypeCHARACTER: + if (ffebld_op (expr) != FFEBLD_opFUNCREF) + break; + + if (sz == FFETARGET_charactersizeNONE) + /* ~~Kludge alert! This should someday be fixed. */ + sz = 24; + + tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1); break; default: - assert ("bad label type" == NULL); - glabel = NULL; break; } - ffelab_set_hook (label, glabel); - } - else - { - glabel = ffelab_hook (label); - } - - return glabel; -} - -#endif -/* Stabilizes the arguments. Don't use this if the lhs and rhs come from - a single source specification (as in the fourth argument of MVBITS). - If the type is NULL_TREE, the type of lhs is used to make the type of - the MODIFY_EXPR. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_modify (tree newtype, tree lhs, - tree rhs) -{ - if (lhs == error_mark_node || rhs == error_mark_node) - return error_mark_node; + break; - if (newtype == NULL_TREE) - newtype = TREE_TYPE (lhs); +#ifdef HAHA + case FFEBLD_opPOWER: + { + tree rtype, ltype; + tree rtmp, ltmp, result; - if (TREE_SIDE_EFFECTS (lhs)) - lhs = stabilize_reference (lhs); + ltype = ffecom_type_expr (ffebld_left (expr)); + rtype = ffecom_type_expr (ffebld_right (expr)); - return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs); -} + rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1); + ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); + result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1); -#endif + tempvar = make_tree_vec (3); + TREE_VEC_ELT (tempvar, 0) = rtmp; + TREE_VEC_ELT (tempvar, 1) = ltmp; + TREE_VEC_ELT (tempvar, 2) = result; + } + break; +#endif /* HAHA */ -/* Register source file name. */ + case FFEBLD_opCONCATENATE: + { + /* This gets special handling, because only one set of temps + is needed for a tree of these -- the tree is treated as + a flattened list of concatenations when generating code. */ -void -ffecom_file (char *name) -{ -#if FFECOM_GCC_INCLUDE - ffecom_file_ (name); -#endif -} + ffecomConcatList_ catlist; + tree ltmp, itmp, result; + int count; + int i; -/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed + catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); + count = ffecom_concat_list_count_ (catlist); - ffestorag st; - ffecom_notify_init_storage(st); + if (count >= 2) + { + ltmp + = ffecom_make_tempvar ("concat_len", + ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count); + itmp + = ffecom_make_tempvar ("concat_item", + ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count); + result + = ffecom_make_tempvar ("concat_res", + char_type_node, + ffecom_concat_list_maxlen_ (catlist), + -1); + + tempvar = make_tree_vec (3); + TREE_VEC_ELT (tempvar, 0) = ltmp; + TREE_VEC_ELT (tempvar, 1) = itmp; + TREE_VEC_ELT (tempvar, 2) = result; + } - Gets called when all possible units in an aggregate storage area (a LOCAL - with equivalences or a COMMON) have been initialized. The initialization - info either is in ffestorag_init or, if that is NULL, - ffestorag_accretion: + for (i = 0; i < count; ++i) + ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, + i)); - ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur - even for an array if the array is one element in length! + ffecom_concat_list_kill_ (catlist); - ffestorag_accretion will contain an opACCTER. It is much like an - opARRTER except it has an ffebit object in it instead of just a size. - The back end can use the info in the ffebit object, if it wants, to - reduce the amount of actual initialization, but in any case it should - kill the ffebit object when done. Also, set accretion to NULL but - init to a non-NULL value. + if (tempvar) + { + ffebld_nonter_set_hook (expr, tempvar); + current_binding_level->prep_state = 1; + } + } + return; - After performing initialization, DO NOT set init to NULL, because that'll - tell the front end it is ok for more initialization to happen. Instead, - set init to an opANY expression or some such thing that you can use to - tell that you've already initialized the object. + case FFEBLD_opCONVERT: + if (bt == FFEINFO_basictypeCHARACTER + && ((ffebld_size_known (ffebld_left (expr)) + == FFETARGET_charactersizeNONE) + || (ffebld_size_known (ffebld_left (expr)) >= sz))) + tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1); + break; + } - 27-Oct-91 JCB 1.1 - Support two-pass FFE. */ + if (tempvar) + { + ffebld_nonter_set_hook (expr, tempvar); + current_binding_level->prep_state = 1; + } -void -ffecom_notify_init_storage (ffestorag st) -{ - ffebld init; /* The initialization expression. */ -#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC - ffetargetOffset size; /* The size of the entity. */ - ffetargetAlign pad; /* Its initial padding. */ -#endif + /* Prepare subexpressions for this expr. */ - if (ffestorag_init (st) == NULL) + switch (ffebld_op (expr)) { - init = ffestorag_accretion (st); - assert (init != NULL); - ffestorag_set_accretion (st, NULL); - ffestorag_set_accretes (st, 0); + case FFEBLD_opPERCENT_LOC: + ffecom_prepare_ptr_to_expr (ffebld_left (expr)); + break; -#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC - /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ - size = ffebld_accter_size (init); - pad = ffebld_accter_pad (init); - ffebit_kill (ffebld_accter_bits (init)); - ffebld_set_op (init, FFEBLD_opARRTER); - ffebld_set_arrter (init, ffebld_accter (init)); - ffebld_arrter_set_size (init, size); - ffebld_arrter_set_pad (init, size); -#endif + case FFEBLD_opPERCENT_VAL: + case FFEBLD_opPERCENT_REF: + ffecom_prepare_expr (ffebld_left (expr)); + break; -#if FFECOM_TWOPASS - ffestorag_set_init (st, init); -#endif - } -#if FFECOM_ONEPASS - else - init = ffestorag_init (st); -#endif + case FFEBLD_opPERCENT_DESCR: + ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr)); + break; -#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */ - ffestorag_set_init (st, ffebld_new_any ()); + case FFEBLD_opITEM: + { + ffebld item; - if (ffebld_op (init) == FFEBLD_opANY) - return; /* Oh, we already did this! */ + for (item = expr; + item != NULL; + item = ffebld_trail (item)) + if (ffebld_head (item) != NULL) + ffecom_prepare_expr (ffebld_head (item)); + } + break; -#if FFECOM_targetCURRENT == FFECOM_targetFFE - { - ffesymbol s; + default: + /* Need to handle character conversion specially. */ + switch (ffebld_arity (expr)) + { + case 2: + ffecom_prepare_expr (ffebld_left (expr)); + ffecom_prepare_expr (ffebld_right (expr)); + break; - if (ffestorag_symbol (st) != NULL) - s = ffestorag_symbol (st); - else - s = ffestorag_typesymbol (st); + case 1: + ffecom_prepare_expr (ffebld_left (expr)); + break; - fprintf (dmpout, "= initialize_storage \"%s\" ", - (s != NULL) ? ffesymbol_text (s) : "(unnamed)"); - ffebld_dump (init); - fputc ('\n', dmpout); - } -#endif + default: + break; + } + } -#endif /* if FFECOM_ONEPASS */ + return; } -/* ffecom_notify_init_symbol -- A symbol is now fully init'ed - - ffesymbol s; - ffecom_notify_init_symbol(s); +/* Prepare expression for reading and writing. - Gets called when all possible units in a symbol (not placed in COMMON - or involved in EQUIVALENCE, unless it as yet has no ffestorag object) - have been initialized. The initialization info either is in - ffesymbol_init or, if that is NULL, ffesymbol_accretion: + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_expr_rw. */ - ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur - even for an array if the array is one element in length! +void +ffecom_prepare_expr_rw (tree type, ffebld expr) +{ + /* This is all we support for now. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - ffesymbol_accretion will contain an opACCTER. It is much like an - opARRTER except it has an ffebit object in it instead of just a size. - The back end can use the info in the ffebit object, if it wants, to - reduce the amount of actual initialization, but in any case it should - kill the ffebit object when done. Also, set accretion to NULL but - init to a non-NULL value. + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} - After performing initialization, DO NOT set init to NULL, because that'll - tell the front end it is ok for more initialization to happen. Instead, - set init to an opANY expression or some such thing that you can use to - tell that you've already initialized the object. +/* Prepare expression for writing. - 27-Oct-91 JCB 1.1 - Support two-pass FFE. */ + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_expr_w. */ void -ffecom_notify_init_symbol (ffesymbol s) +ffecom_prepare_expr_w (tree type, ffebld expr) { - ffebld init; /* The initialization expression. */ -#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC - ffetargetOffset size; /* The size of the entity. */ - ffetargetAlign pad; /* Its initial padding. */ -#endif + /* This is all we support for now. */ + assert (type == NULL_TREE || type == ffecom_type_expr (expr)); - if (ffesymbol_storage (s) == NULL) - return; /* Do nothing until COMMON/EQUIVALENCE - possibilities checked. */ + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; +} - if ((ffesymbol_init (s) == NULL) - && ((init = ffesymbol_accretion (s)) != NULL)) - { - ffesymbol_set_accretion (s, NULL); - ffesymbol_set_accretes (s, 0); +/* Prepare expression for returning. -#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC - /* For GNU backend, just turn ACCTER into ARRTER and proceed. */ - size = ffebld_accter_size (init); - pad = ffebld_accter_pad (init); - ffebit_kill (ffebld_accter_bits (init)); - ffebld_set_op (init, FFEBLD_opARRTER); - ffebld_set_arrter (init, ffebld_accter (init)); - ffebld_arrter_set_size (init, size); - ffebld_arrter_set_pad (init, size); -#endif + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_return_expr. */ -#if FFECOM_TWOPASS - ffesymbol_set_init (s, init); -#endif - } -#if FFECOM_ONEPASS - else - init = ffesymbol_init (s); -#endif +void +ffecom_prepare_return_expr (ffebld expr) +{ + assert (current_binding_level->prep_state < 2); -#if FFECOM_ONEPASS - ffesymbol_set_init (s, ffebld_new_any ()); + if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE + && ffecom_is_altreturning_ + && expr != NULL) + ffecom_prepare_expr (expr); +} - if (ffebld_op (init) == FFEBLD_opANY) - return; /* Oh, we already did this! */ +/* Prepare pointer to expression. -#if FFECOM_targetCURRENT == FFECOM_targetFFE - fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s)); - ffebld_dump (init); - fputc ('\n', dmpout); -#endif + Like ffecom_prepare_expr, except for expressions to be evaluated + via ffecom_ptr_to_expr. */ -#endif /* if FFECOM_ONEPASS */ +void +ffecom_prepare_ptr_to_expr (ffebld expr) +{ + /* ~~For now, it seems to be the same thing. */ + ffecom_prepare_expr (expr); + return; } -/* ffecom_notify_primary_entry -- Learn which is the primary entry point +/* Transform expression into constant pointer-to-expression tree. - ffesymbol s; - ffecom_notify_primary_entry(s); + If the expression can be transformed into a pointer-to-expression tree + that is constant, that is done, and the tree returned. Else NULL_TREE + is returned. - Gets called when implicit or explicit PROGRAM statement seen or when - FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary - global symbol that serves as the entry point. */ + That way, a caller can attempt to provide compile-time initialization + of a variable and, if that fails, *then* choose to start a new block + and resort to using temporaries, as appropriate. */ -void -ffecom_notify_primary_entry (ffesymbol s) +tree +ffecom_ptr_to_const_expr (ffebld expr) { - ffecom_primary_entry_ = s; - ffecom_primary_entry_kind_ = ffesymbol_kind (s); + if (! expr) + return integer_zero_node; - if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) - || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)) - ffecom_primary_entry_is_proc_ = TRUE; - else - ffecom_primary_entry_is_proc_ = FALSE; + if (ffebld_op (expr) == FFEBLD_opANY) + return error_mark_node; - if (!ffe_is_silent ()) + if (ffebld_arity (expr) == 0 + && (ffebld_op (expr) != FFEBLD_opSYMTER + || ffebld_where (expr) == FFEINFO_whereCOMMON + || ffebld_where (expr) == FFEINFO_whereGLOBAL + || ffebld_where (expr) == FFEINFO_whereINTRINSIC)) { - if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM) - fprintf (stderr, "%s:\n", ffesymbol_text (s)); - else - fprintf (stderr, " %s:\n", ffesymbol_text (s)); + tree t; + + t = ffecom_ptr_to_expr (expr); + assert (TREE_CONSTANT (t)); + return t; } + return NULL_TREE; +} + +/* ffecom_return_expr -- Returns return-value expr given alt return expr + + tree rtn; // NULL_TREE means use expand_null_return() + ffebld expr; // NULL if no alt return expr to RETURN stmt + rtn = ffecom_return_expr(expr); + + Based on the program unit type and other info (like return function + type, return master function type when alternate ENTRY points, + whether subroutine has any alternate RETURN points, etc), returns the + appropriate expression to be returned to the caller, or NULL_TREE + meaning no return value or the caller expects it to be returned somewhere + else (which is handled by other parts of this module). */ + #if FFECOM_targetCURRENT == FFECOM_targetGCC - if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) +tree +ffecom_return_expr (ffebld expr) +{ + tree rtn; + + switch (ffecom_primary_entry_kind_) { - ffebld list; - ffebld arg; + case FFEINFO_kindPROGRAM: + case FFEINFO_kindBLOCKDATA: + rtn = NULL_TREE; + break; - for (list = ffesymbol_dummyargs (s); - list != NULL; - list = ffebld_trail (list)) - { - arg = ffebld_head (list); - if (ffebld_op (arg) == FFEBLD_opSTAR) - { - ffecom_is_altreturning_ = TRUE; - break; - } + case FFEINFO_kindSUBROUTINE: + if (!ffecom_is_altreturning_) + rtn = NULL_TREE; /* No alt returns, never an expr. */ + else if (expr == NULL) + rtn = integer_zero_node; + else + rtn = ffecom_expr (expr); + break; + + case FFEINFO_kindFUNCTION: + if ((ffecom_multi_retval_ != NULL_TREE) + || (ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCHARACTER) + || ((ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCOMPLEX) + && (ffecom_num_entrypoints_ == 0) + && ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Value is returned by direct assignment + into (implicit) dummy. */ + rtn = NULL_TREE; + break; } - } -#endif -} + rtn = ffecom_func_result_; +#if 0 + /* Spurious error if RETURN happens before first reference! So elide + this code. In particular, for debugging registry, rtn should always + be non-null after all, but TREE_USED won't be set until we encounter + a reference in the code. Perfectly okay (but weird) code that, + e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in + this diagnostic for no reason. Have people use -O -Wuninitialized + and leave it to the back end to find obviously weird cases. */ -FILE * -ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c) -{ -#if FFECOM_GCC_INCLUDE - return ffecom_open_include_ (name, l, c); -#else - return fopen (name, "r"); + /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid + situation; if the return value has never been referenced, it won't + have a tree under 2pass mode. */ + if ((rtn == NULL_TREE) + || !TREE_USED (rtn)) + { + ffebad_start (FFEBAD_RETURN_VALUE_UNSET); + ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_), + ffesymbol_where_column (ffecom_primary_entry_)); + ffebad_string (ffesymbol_text (ffesymbol_funcresult + (ffecom_primary_entry_))); + ffebad_finish (); + } #endif -} - -/* Clean up after making automatically popped call-arg temps. + break; - Call this in pairs with push_calltemps around calls to - ffecom_arg_ptr_to_expr if the latter might use temporaries. - Any temporaries made within the outermost sequence of - push_calltemps and pop_calltemps, that are marked as "auto-pop" - meaning they won't be explicitly popped (freed), are popped - at this point so they can be reused later. + default: + assert ("bad unit kind" == NULL); + case FFEINFO_kindANY: + rtn = error_mark_node; + break; + } - NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_ - should come in == 1, and all of the in-use auto-pop temps - should have DECL_CONTEXT (temp->t) == current_function_decl. - Moreover, these temps should _never_ be re-used in future - calls to ffecom_push_tempvar -- since current_function_decl will - never be the same again. + return rtn; +} - SO, it could be a minor win in terms of compile time to just - strip these temps off the list. That is, if the above assumptions - are correct, just remove from the list of temps any temp - that is both in-use and has DECL_CONTEXT (temp->t) - == current_function_decl, when called from ffecom_gen_sfuncdef_. */ +#endif +/* Do save_expr only if tree is not error_mark_node. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_pop_calltemps () +tree +ffecom_save_tree (tree t) { - ffecomTemp_ temp; - - assert (ffecom_pending_calls_ > 0); - - if (--ffecom_pending_calls_ == 0) - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - if (temp->auto_pop) - temp->in_use = FALSE; + return save_expr (t); } - #endif -/* Mark latest temp with given tree as no longer in use. */ + +/* Start a compound statement (block). */ #if FFECOM_targetCURRENT == FFECOM_targetGCC void -ffecom_pop_tempvar (tree t) +ffecom_start_compstmt (void) { - ffecomTemp_ temp; - - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - if (temp->in_use && (temp->t == t)) - { - assert (!temp->auto_pop); - temp->in_use = FALSE; - return; - } - else - assert (temp->t != t); - - assert ("couldn't ffecom_pop_tempvar!" != NULL); + bison_rule_pushlevel_ (); } +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ -#endif -/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front - - tree t; - ffebld expr; // FFE expression. - tree = ffecom_ptr_to_expr(expr); - - Like ffecom_expr, but sticks address-of in front of most things. */ +/* Public entry point for front end to access start_decl. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_ptr_to_expr (ffebld expr) +ffecom_start_decl (tree decl, bool is_initialized) { - tree item; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffesymbol s; - - assert (expr != NULL); - - switch (ffebld_op (expr)) - { - case FFEBLD_opSYMTER: - s = ffebld_symter (expr); - if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) - { - ffecomGfrt ix; - - ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr)); - assert (ix != FFECOM_gfrt); - if ((item = ffecom_gfrt_[ix]) == NULL_TREE) - { - ffecom_make_gfrt_ (ix); - item = ffecom_gfrt_[ix]; - } - } - else - { - item = ffesymbol_hook (s).decl_tree; - if (item == NULL_TREE) - { - s = ffecom_sym_transform_ (s); - item = ffesymbol_hook (s).decl_tree; - } - } - assert (item != NULL); - if (item == error_mark_node) - return item; - if (!ffesymbol_hook (s).addr) - item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), - item); - return item; - - case FFEBLD_opARRAYREF: - { - ffebld dims[FFECOM_dimensionsMAX]; - tree array; - int i; - - item = ffecom_ptr_to_expr (ffebld_left (expr)); - - if (item == error_mark_node) - return item; - - if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) - && !mark_addressable (item)) - return error_mark_node; /* Make sure non-const ref is to - non-reg. */ - - /* Build up ARRAY_REFs in reverse order (since we're column major - here in Fortran land). */ + DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; + return start_decl (decl, FALSE); +} - for (i = 0, expr = ffebld_right (expr); - expr != NULL; - expr = ffebld_trail (expr)) - dims[i++] = ffebld_head (expr); +#endif +/* ffecom_sym_commit -- Symbol's state being committed to reality - for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); - i >= 0; - --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) - { - /* The initial subtraction should happen in the original type so - that (possible) negative values are handled appropriately. */ - item - = ffecom_2 (PLUS_EXPR, - build_pointer_type (TREE_TYPE (array)), - item, - size_binop (MULT_EXPR, - size_in_bytes (TREE_TYPE (array)), - convert (sizetype, - fold (build (MINUS_EXPR, - TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))), - ffecom_expr (dims[i]), - TYPE_MIN_VALUE (TYPE_DOMAIN (array))))))); - } - } - return item; + ffesymbol s; + ffecom_sym_commit(s); - case FFEBLD_opCONTER: + Does whatever the backend needs when a symbol is committed after having + been backtrackable for a period of time. */ - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_sym_commit (ffesymbol s UNUSED) +{ + assert (!ffesymbol_retractable ()); +} - item = ffecom_constantunion (&ffebld_constant_union - (ffebld_conter (expr)), bt, kt, - ffecom_tree_type[bt][kt]); - if (item == error_mark_node) - return error_mark_node; - item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), - item); - return item; +#endif +/* ffecom_sym_end_transition -- Perform end transition on all symbols - case FFEBLD_opANY: - return error_mark_node; + ffecom_sym_end_transition(); - default: - assert (ffecom_pending_calls_ > 0); + Does backend-specific stuff and also calls ffest_sym_end_transition + to do the necessary FFE stuff. - bt = ffeinfo_basictype (ffebld_info (expr)); - kt = ffeinfo_kindtype (ffebld_info (expr)); + Backtracking is never enabled when this fn is called, so don't worry + about it. */ - item = ffecom_expr (expr); - if (item == error_mark_node) - return error_mark_node; +ffesymbol +ffecom_sym_end_transition (ffesymbol s) +{ + ffestorag st; - /* The back end currently optimizes a bit too zealously for us, in that - we fail JCB001 if the following block of code is omitted. It checks - to see if the transformed expression is a symbol or array reference, - and encloses it in a SAVE_EXPR if that is the case. */ + assert (!ffesymbol_retractable ()); - STRIP_NOPS (item); - if ((TREE_CODE (item) == VAR_DECL) - || (TREE_CODE (item) == PARM_DECL) - || (TREE_CODE (item) == RESULT_DECL) - || (TREE_CODE (item) == INDIRECT_REF) - || (TREE_CODE (item) == ARRAY_REF) - || (TREE_CODE (item) == COMPONENT_REF) -#ifdef OFFSET_REF - || (TREE_CODE (item) == OFFSET_REF) -#endif - || (TREE_CODE (item) == BUFFER_REF) - || (TREE_CODE (item) == REALPART_EXPR) - || (TREE_CODE (item) == IMAGPART_EXPR)) - { - item = ffecom_save_tree (item); - } + s = ffest_sym_end_transition (s); - item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), - item); - return item; +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA) + && (ffesymbol_where (s) == FFEINFO_whereGLOBAL)) + { + ffecom_list_blockdata_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_blockdata_); } - - assert ("fall-through error" == NULL); - return error_mark_node; -} - #endif -/* Prepare to make call-arg temps. - - Call this in pairs with pop_calltemps around calls to - ffecom_arg_ptr_to_expr if the latter might use temporaries. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_push_calltemps () -{ - ffecom_pending_calls_++; -} -#endif -/* Obtain a temp var with given data type. + /* This is where we finally notice that a symbol has partial initialization + and finalize it. */ - Returns a VAR_DECL tree of a currently (that is, at the current - statement being compiled) not in use and having the given data type, - making a new one if necessary. size is FFETARGET_charactersizeNONE - for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is - -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if - ffecom_pop_tempvar won't be called, meaning temp will be freed - when #pending calls goes to zero. */ + if (ffesymbol_accretion (s) != NULL) + { + assert (ffesymbol_init (s) == NULL); + ffecom_notify_init_symbol (s); + } + else if (((st = ffesymbol_storage (s)) != NULL) + && ((st = ffestorag_parent (st)) != NULL) + && (ffestorag_accretion (st) != NULL)) + { + assert (ffestorag_init (st) == NULL); + ffecom_notify_init_storage (st); + } #if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements, - bool auto_pop) -{ - ffecomTemp_ temp; - int yes; - tree t; - static int mynumber; + if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON) + && (ffesymbol_where (s) == FFEINFO_whereLOCAL) + && (ffesymbol_storage (s) != NULL)) + { + ffecom_list_common_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_common_); + } +#endif - assert (!auto_pop || (ffecom_pending_calls_ > 0)); + return s; +} - if (type == error_mark_node) - return error_mark_node; +/* ffecom_sym_exec_transition -- Perform exec transition on all symbols - for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) - { - if (temp->in_use - || (temp->type != type) - || (temp->size != size) - || (temp->elements != elements) - || (DECL_CONTEXT (temp->t) != current_function_decl)) - continue; + ffecom_sym_exec_transition(); - temp->in_use = TRUE; - temp->auto_pop = auto_pop; - return temp->t; - } + Does backend-specific stuff and also calls ffest_sym_exec_transition + to do the necessary FFE stuff. - /* Create a new temp. */ + See the long-winded description in ffecom_sym_learned for info + on handling the situation where backtracking is inhibited. */ - yes = suspend_momentary (); +ffesymbol +ffecom_sym_exec_transition (ffesymbol s) +{ + s = ffest_sym_exec_transition (s); - if (size != FFETARGET_charactersizeNONE) - type = build_array_type (type, - build_range_type (ffecom_f2c_ftnlen_type_node, - ffecom_f2c_ftnlen_one_node, - build_int_2 (size, 0))); - if (elements != -1) - type = build_array_type (type, - build_range_type (integer_type_node, - integer_zero_node, - build_int_2 (elements - 1, - 0))); - t = build_decl (VAR_DECL, - ffecom_get_invented_identifier ("__g77_expr_%d", NULL, - mynumber++), - type); + return s; +} - /* This temp must be put in the same scope as the containing BLOCK - (aka function), but for reasons that should be explained elsewhere, - the GBE normally decides it should be in a "phantom BLOCK" associated - with the expand_start_stmt_expr() call. So push the topmost - sequence back onto the GBE's internal stack before telling it - about the decl, then restore it afterwards. */ - push_topmost_sequence (); +/* ffecom_sym_learned -- Initial or more info gained on symbol after exec - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + ffesymbol s; + s = ffecom_sym_learned(s); - pop_topmost_sequence (); + Called when a new symbol is seen after the exec transition or when more + info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when + it arrives here is that all its latest info is updated already, so its + state may be UNCERTAIN or UNDERSTOOD, it might already have the hook + field filled in if its gone through here or exec_transition first, and + so on. - resume_momentary (yes); + The backend probably wants to check ffesymbol_retractable() to see if + backtracking is in effect. If so, the FFE's changes to the symbol may + be retracted (undone) or committed (ratified), at which time the + appropriate ffecom_sym_retract or _commit function will be called + for that function. - temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_", - sizeof (*temp)); + If the backend has its own backtracking mechanism, great, use it so that + committal is a simple operation. Though it doesn't make much difference, + I suppose: the reason for tentative symbol evolution in the FFE is to + enable error detection in weird incorrect statements early and to disable + incorrect error detection on a correct statement. The backend is not + likely to introduce any information that'll get involved in these + considerations, so it is probably just fine that the implementation + model for this fn and for _exec_transition is to not do anything + (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE + and instead wait until ffecom_sym_commit is called (which it never + will be as long as we're using ambiguity-detecting statement analysis in + the FFE, which we are initially to shake out the code, but don't depend + on this), otherwise go ahead and do whatever is needed. - temp->next = ffecom_latest_temp_; - temp->type = type; - temp->t = t; - temp->size = size; - temp->elements = elements; - temp->in_use = TRUE; - temp->auto_pop = auto_pop; + In essence, then, when this fn and _exec_transition get called while + backtracking is enabled, a general mechanism would be to flag which (or + both) of these were called (and in what order? neat question as to what + might happen that I'm too lame to think through right now) and then when + _commit is called reproduce the original calling sequence, if any, for + the two fns (at which point backtracking will, of course, be disabled). */ - ffecom_latest_temp_ = temp; +ffesymbol +ffecom_sym_learned (ffesymbol s) +{ + ffestorag_exec_layout (s); - return t; + return s; } -#endif -/* ffecom_return_expr -- Returns return-value expr given alt return expr +/* ffecom_sym_retract -- Symbol's state being retracted from reality - tree rtn; // NULL_TREE means use expand_null_return() - ffebld expr; // NULL if no alt return expr to RETURN stmt - rtn = ffecom_return_expr(expr); + ffesymbol s; + ffecom_sym_retract(s); - Based on the program unit type and other info (like return function - type, return master function type when alternate ENTRY points, - whether subroutine has any alternate RETURN points, etc), returns the - appropriate expression to be returned to the caller, or NULL_TREE - meaning no return value or the caller expects it to be returned somewhere - else (which is handled by other parts of this module). */ + Does whatever the backend needs when a symbol is retracted after having + been backtrackable for a period of time. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_return_expr (ffebld expr) +void +ffecom_sym_retract (ffesymbol s UNUSED) { - tree rtn; + assert (!ffesymbol_retractable ()); - switch (ffecom_primary_entry_kind_) +#if 0 /* GCC doesn't commit any backtrackable sins, + so nothing needed here. */ + switch (ffesymbol_hook (s).state) { - case FFEINFO_kindPROGRAM: - case FFEINFO_kindBLOCKDATA: - rtn = NULL_TREE; + case 0: /* nothing happened yet. */ break; - case FFEINFO_kindSUBROUTINE: - if (!ffecom_is_altreturning_) - rtn = NULL_TREE; /* No alt returns, never an expr. */ - else if (expr == NULL) - rtn = integer_zero_node; - else - rtn = ffecom_expr (expr); + case 1: /* exec transition happened. */ break; - case FFEINFO_kindFUNCTION: - if ((ffecom_multi_retval_ != NULL_TREE) - || (ffesymbol_basictype (ffecom_primary_entry_) - == FFEINFO_basictypeCHARACTER) - || ((ffesymbol_basictype (ffecom_primary_entry_) - == FFEINFO_basictypeCOMPLEX) - && (ffecom_num_entrypoints_ == 0) - && ffesymbol_is_f2c (ffecom_primary_entry_))) - { /* Value is returned by direct assignment - into (implicit) dummy. */ - rtn = NULL_TREE; - break; - } - rtn = ffecom_func_result_; -#if 0 - /* Spurious error if RETURN happens before first reference! So elide - this code. In particular, for debugging registry, rtn should always - be non-null after all, but TREE_USED won't be set until we encounter - a reference in the code. Perfectly okay (but weird) code that, - e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in - this diagnostic for no reason. Have people use -O -Wuninitialized - and leave it to the back end to find obviously weird cases. */ + case 2: /* learned happened. */ + break; - /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid - situation; if the return value has never been referenced, it won't - have a tree under 2pass mode. */ - if ((rtn == NULL_TREE) - || !TREE_USED (rtn)) - { - ffebad_start (FFEBAD_RETURN_VALUE_UNSET); - ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_), - ffesymbol_where_column (ffecom_primary_entry_)); - ffebad_string (ffesymbol_text (ffesymbol_funcresult - (ffecom_primary_entry_))); - ffebad_finish (); - } -#endif + case 3: /* learned then exec. */ + break; + + case 4: /* exec then learned. */ break; default: - assert ("bad unit kind" == NULL); - case FFEINFO_kindANY: - rtn = error_mark_node; + assert ("bad hook state" == NULL); break; } +#endif +} - return rtn; +#endif +/* Create temporary gcc label. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_temp_label () +{ + tree glabel; + static int mynumber = 0; + + glabel = build_decl (LABEL_DECL, + ffecom_get_invented_identifier ("__g77_label_%d", + NULL, + mynumber++), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + + return glabel; } #endif -/* Do save_expr only if tree is not error_mark_node. */ +/* Return an expression that is usable as an arg in a conditional context + (IF, DO WHILE, .NOT., and so on). + + Use the one provided for the back end as of >2.6.0. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_save_tree (tree t) +ffecom_truth_value (tree expr) { - return save_expr (t); + return truthvalue_conversion (expr); } + #endif +/* Return the inversion of a truth value (the inversion of what + ffecom_truth_value builds). -/* Public entry point for front end to access start_decl. */ + Apparently invert_truthvalue, which is properly in the back end, is + enough for now, so just use it. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC tree -ffecom_start_decl (tree decl, bool is_initialized) +ffecom_truth_value_invert (tree expr) { - DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; - return start_decl (decl, FALSE); + return invert_truthvalue (ffecom_truth_value (expr)); } #endif -/* ffecom_sym_commit -- Symbol's state being committed to reality - ffesymbol s; - ffecom_sym_commit(s); +/* Return the tree that is the type of the expression, as would be + returned in TREE_TYPE(ffecom_expr(expr)), without otherwise + transforming the expression, generating temporaries, etc. */ - Does whatever the backend needs when a symbol is committed after having - been backtrackable for a period of time. */ +tree +ffecom_type_expr (ffebld expr) +{ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree tree_type; + + assert (expr != NULL); + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + tree_type = ffecom_tree_type[bt][kt]; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opUPLUS: + case FFEBLD_opPAREN: + case FFEBLD_opUMINUS: + case FFEBLD_opADD: + case FFEBLD_opSUBTRACT: + case FFEBLD_opMULTIPLY: + case FFEBLD_opDIVIDE: + case FFEBLD_opPOWER: + case FFEBLD_opNOT: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBRREF: + case FFEBLD_opAND: + case FFEBLD_opOR: + case FFEBLD_opXOR: + case FFEBLD_opNEQV: + case FFEBLD_opEQV: + case FFEBLD_opCONVERT: + case FFEBLD_opLT: + case FFEBLD_opLE: + case FFEBLD_opEQ: + case FFEBLD_opNE: + case FFEBLD_opGT: + case FFEBLD_opGE: + case FFEBLD_opPERCENT_LOC: + return tree_type; + + case FFEBLD_opACCTER: + case FFEBLD_opARRTER: + case FFEBLD_opITEM: + case FFEBLD_opSTAR: + case FFEBLD_opBOUNDS: + case FFEBLD_opREPEAT: + case FFEBLD_opLABTER: + case FFEBLD_opLABTOK: + case FFEBLD_opIMPDO: + case FFEBLD_opCONCATENATE: + case FFEBLD_opSUBSTR: + default: + assert ("bad op for ffecom_type_expr" == NULL); + /* Fall through. */ + case FFEBLD_opANY: + return error_mark_node; + } +} + +/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points + + If the PARM_DECL already exists, return it, else create it. It's an + integer_type_node argument for the master function that implements a + subroutine or function with more than one entrypoint and is bound at + run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for + first ENTRY statement, and so on). */ #if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_sym_commit (ffesymbol s UNUSED) +tree +ffecom_which_entrypoint_decl () { - assert (!ffesymbol_retractable ()); + assert (ffecom_which_entrypoint_decl_ != NULL_TREE); + + return ffecom_which_entrypoint_decl_; } #endif -/* ffecom_sym_end_transition -- Perform end transition on all symbols + +/* The following sections consists of private and public functions + that have the same names and perform roughly the same functions + as counterparts in the C front end. Changes in the C front end + might affect how things should be done here. Only functions + needed by the back end should be public here; the rest should + be private (static in the C sense). Functions needed by other + g77 front-end modules should be accessed by them via public + ffecom_* names, which should themselves call private versions + in this section so the private versions are easy to recognize + when upgrading to a new gcc and finding interesting changes + in the front end. - ffecom_sym_end_transition(); + Functions named after rule "foo:" in c-parse.y are named + "bison_rule_foo_" so they are easy to find. */ - Does backend-specific stuff and also calls ffest_sym_end_transition - to do the necessary FFE stuff. +#if FFECOM_targetCURRENT == FFECOM_targetGCC - Backtracking is never enabled when this fn is called, so don't worry - about it. */ +static void +bison_rule_pushlevel_ () +{ + emit_line_note (input_filename, lineno); + pushlevel (0); + clear_last_expr (); + push_momentary (); + expand_start_bindings (0); +} -ffesymbol -ffecom_sym_end_transition (ffesymbol s) +static tree +bison_rule_compstmt_ () { - ffestorag st; + tree t; + int keep = kept_level_p (); - assert (!ffesymbol_retractable ()); + /* Make the temps go away. */ + if (! keep) + current_binding_level->names = NULL_TREE; - s = ffest_sym_end_transition (s); + emit_line_note (input_filename, lineno); + expand_end_bindings (getdecls (), keep, 0); + t = poplevel (keep, 1, 0); + pop_momentary (); -#if FFECOM_targetCURRENT == FFECOM_targetGCC - if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA) - && (ffesymbol_where (s) == FFEINFO_whereGLOBAL)) - { - ffecom_list_blockdata_ - = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, - FFEINTRIN_specNONE, - FFEINTRIN_impNONE), - ffecom_list_blockdata_); - } -#endif + return t; +} - /* This is where we finally notice that a symbol has partial initialization - and finalize it. */ +/* Return a definition for a builtin function named NAME and whose data type + is TYPE. TYPE should be a function type with argument types. + FUNCTION_CODE tells later passes how to compile calls to this function. + See tree.h for its possible values. - if (ffesymbol_accretion (s) != NULL) - { - assert (ffesymbol_init (s) == NULL); - ffecom_notify_init_symbol (s); - } - else if (((st = ffesymbol_storage (s)) != NULL) - && ((st = ffestorag_parent (st)) != NULL) - && (ffestorag_accretion (st) != NULL)) - { - assert (ffestorag_init (st) == NULL); - ffecom_notify_init_storage (st); - } + If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, + the name to be called if we can't opencode the function. */ -#if FFECOM_targetCURRENT == FFECOM_targetGCC - if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON) - && (ffesymbol_where (s) == FFEINFO_whereLOCAL) - && (ffesymbol_storage (s) != NULL)) +static tree +builtin_function (const char *name, tree type, + enum built_in_function function_code, + const char *library_name) +{ + tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + if (library_name) + DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); + make_decl_rtl (decl, NULL_PTR, 1); + pushdecl (decl); + if (function_code != NOT_BUILT_IN) { - ffecom_list_common_ - = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, - FFEINTRIN_specNONE, - FFEINTRIN_impNONE), - ffecom_list_common_); + DECL_BUILT_IN (decl) = 1; + DECL_FUNCTION_CODE (decl) = function_code; } -#endif - return s; + return decl; } -/* ffecom_sym_exec_transition -- Perform exec transition on all symbols - - ffecom_sym_exec_transition(); - - Does backend-specific stuff and also calls ffest_sym_exec_transition - to do the necessary FFE stuff. +/* Handle when a new declaration NEWDECL + has the same name as an old one OLDDECL + in the same binding contour. + Prints an error message if appropriate. - See the long-winded description in ffecom_sym_learned for info - on handling the situation where backtracking is inhibited. */ + If safely possible, alter OLDDECL to look like NEWDECL, and return 1. + Otherwise, return 0. */ -ffesymbol -ffecom_sym_exec_transition (ffesymbol s) +static int +duplicate_decls (tree newdecl, tree olddecl) { - s = ffest_sym_exec_transition (s); - - return s; -} - -/* ffecom_sym_learned -- Initial or more info gained on symbol after exec - - ffesymbol s; - s = ffecom_sym_learned(s); - - Called when a new symbol is seen after the exec transition or when more - info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when - it arrives here is that all its latest info is updated already, so its - state may be UNCERTAIN or UNDERSTOOD, it might already have the hook - field filled in if its gone through here or exec_transition first, and - so on. + int types_match = 1; + int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_INITIAL (newdecl) != 0); + tree oldtype = TREE_TYPE (olddecl); + tree newtype = TREE_TYPE (newdecl); - The backend probably wants to check ffesymbol_retractable() to see if - backtracking is in effect. If so, the FFE's changes to the symbol may - be retracted (undone) or committed (ratified), at which time the - appropriate ffecom_sym_retract or _commit function will be called - for that function. + if (olddecl == newdecl) + return 1; - If the backend has its own backtracking mechanism, great, use it so that - committal is a simple operation. Though it doesn't make much difference, - I suppose: the reason for tentative symbol evolution in the FFE is to - enable error detection in weird incorrect statements early and to disable - incorrect error detection on a correct statement. The backend is not - likely to introduce any information that'll get involved in these - considerations, so it is probably just fine that the implementation - model for this fn and for _exec_transition is to not do anything - (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE - and instead wait until ffecom_sym_commit is called (which it never - will be as long as we're using ambiguity-detecting statement analysis in - the FFE, which we are initially to shake out the code, but don't depend - on this), otherwise go ahead and do whatever is needed. + if (TREE_CODE (newtype) == ERROR_MARK + || TREE_CODE (oldtype) == ERROR_MARK) + types_match = 0; - In essence, then, when this fn and _exec_transition get called while - backtracking is enabled, a general mechanism would be to flag which (or - both) of these were called (and in what order? neat question as to what - might happen that I'm too lame to think through right now) and then when - _commit is called reproduce the original calling sequence, if any, for - the two fns (at which point backtracking will, of course, be disabled). */ + /* New decl is completely inconsistent with the old one => + tell caller to replace the old one. + This is always an error except in the case of shadowing a builtin. */ + if (TREE_CODE (olddecl) != TREE_CODE (newdecl)) + return 0; -ffesymbol -ffecom_sym_learned (ffesymbol s) -{ - ffestorag_exec_layout (s); + /* For real parm decl following a forward decl, + return 1 so old decl will be reused. */ + if (types_match && TREE_CODE (newdecl) == PARM_DECL + && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl)) + return 1; - return s; -} + /* The new declaration is the same kind of object as the old one. + The declarations may partially match. Print warnings if they don't + match enough. Ultimately, copy most of the information from the new + decl to the old one, and keep using the old one. */ -/* ffecom_sym_retract -- Symbol's state being retracted from reality + if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl)) + { + /* A function declaration for a built-in function. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* Accept the return type of the new declaration if same modes. */ + tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl)); + tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl)); - ffesymbol s; - ffecom_sym_retract(s); + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the + permanent one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } - Does whatever the backend needs when a symbol is retracted after having - been backtrackable for a period of time. */ + if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype)) + { + /* Function types may be shared, so we can't just modify + the return type of olddecl's function type. */ + tree newtype + = build_function_type (newreturntype, + TYPE_ARG_TYPES (TREE_TYPE (olddecl))); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -void -ffecom_sym_retract (ffesymbol s UNUSED) -{ - assert (!ffesymbol_retractable ()); + types_match = 1; + if (types_match) + TREE_TYPE (olddecl) = newtype; + } -#if 0 /* GCC doesn't commit any backtrackable sins, - so nothing needed here. */ - switch (ffesymbol_hook (s).state) + pop_obstacks (); + } + if (!types_match) + return 0; + } + else if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_SOURCE_LINE (olddecl) == 0) { - case 0: /* nothing happened yet. */ - break; + /* A function declaration for a predeclared function + that isn't actually built in. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* If the types don't match, preserve volatility indication. + Later on, we will discard everything else about the + default declaration. */ + TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); + } + } - case 1: /* exec transition happened. */ - break; + /* Copy all the DECL_... slots specified in the new decl + except for any that we copy here from the old type. - case 2: /* learned happened. */ - break; + Past this point, we don't change OLDTYPE and NEWTYPE + even if we change the types of NEWDECL and OLDDECL. */ - case 3: /* learned then exec. */ - break; + if (types_match) + { + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the permanent + one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } - case 4: /* exec then learned. */ - break; + /* Merge the data types specified in the two decls. */ + if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl)) + TREE_TYPE (newdecl) + = TREE_TYPE (olddecl) + = TREE_TYPE (newdecl); - default: - assert ("bad hook state" == NULL); - break; - } -#endif -} + /* Lay the type out, unless already done. */ + if (oldtype != TREE_TYPE (newdecl)) + { + if (TREE_TYPE (newdecl) != error_mark_node) + layout_type (TREE_TYPE (newdecl)); + if (TREE_CODE (newdecl) != FUNCTION_DECL + && TREE_CODE (newdecl) != TYPE_DECL + && TREE_CODE (newdecl) != CONST_DECL) + layout_decl (newdecl, 0); + } + else + { + /* Since the type is OLDDECL's, make OLDDECL's size go with. */ + DECL_SIZE (newdecl) = DECL_SIZE (olddecl); + if (TREE_CODE (olddecl) != FUNCTION_DECL) + if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) + DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); + } -#endif -/* Create temporary gcc label. */ + /* Keep the old rtl since we can safely use it. */ + DECL_RTL (newdecl) = DECL_RTL (olddecl); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_temp_label () -{ - tree glabel; - static int mynumber = 0; + /* Merge the type qualifiers. */ + if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl) + && !TREE_THIS_VOLATILE (newdecl)) + TREE_THIS_VOLATILE (olddecl) = 0; + if (TREE_READONLY (newdecl)) + TREE_READONLY (olddecl) = 1; + if (TREE_THIS_VOLATILE (newdecl)) + { + TREE_THIS_VOLATILE (olddecl) = 1; + if (TREE_CODE (newdecl) == VAR_DECL) + make_var_volatile (newdecl); + } - glabel = build_decl (LABEL_DECL, - ffecom_get_invented_identifier ("__g77_label_%d", - NULL, - mynumber++), - void_type_node); - DECL_CONTEXT (glabel) = current_function_decl; - DECL_MODE (glabel) = VOIDmode; + /* Keep source location of definition rather than declaration. + Likewise, keep decl at outer scope. */ + if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0) + || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0)) + { + DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl); + DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl); - return glabel; -} + if (DECL_CONTEXT (olddecl) == 0 + && TREE_CODE (newdecl) != FUNCTION_DECL) + DECL_CONTEXT (newdecl) = 0; + } -#endif -/* Return an expression that is usable as an arg in a conditional context - (IF, DO WHILE, .NOT., and so on). + /* Merge the unused-warning information. */ + if (DECL_IN_SYSTEM_HEADER (olddecl)) + DECL_IN_SYSTEM_HEADER (newdecl) = 1; + else if (DECL_IN_SYSTEM_HEADER (newdecl)) + DECL_IN_SYSTEM_HEADER (olddecl) = 1; - Use the one provided for the back end as of >2.6.0. */ + /* Merge the initialization information. */ + if (DECL_INITIAL (newdecl) == 0) + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_truth_value (tree expr) -{ - return truthvalue_conversion (expr); -} + /* Merge the section attribute. + We want to issue an error if the sections conflict but that must be + done later in decl_attributes since we are called before attributes + are assigned. */ + if (DECL_SECTION_NAME (newdecl) == NULL_TREE) + DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl); +#if BUILT_FOR_270 + if (TREE_CODE (newdecl) == FUNCTION_DECL) + { + DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); + DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); + } #endif -/* Return the inversion of a truth value (the inversion of what - ffecom_truth_value builds). - Apparently invert_truthvalue, which is properly in the back end, is - enough for now, so just use it. */ - -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_truth_value_invert (tree expr) -{ - return invert_truthvalue (ffecom_truth_value (expr)); -} + pop_obstacks (); + } + /* If cannot merge, then use the new type and qualifiers, + and don't preserve the old rtl. */ + else + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + TREE_READONLY (olddecl) = TREE_READONLY (newdecl); + TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl); + TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl); + } -#endif -/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points + /* Merge the storage class information. */ + /* For functions, static overrides non-static. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL) + { + TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl); + /* This is since we don't automatically + copy the attributes of NEWDECL into OLDDECL. */ + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + /* If this clears `static', clear it in the identifier too. */ + if (! TREE_PUBLIC (olddecl)) + TREE_PUBLIC (DECL_NAME (olddecl)) = 0; + } + if (DECL_EXTERNAL (newdecl)) + { + TREE_STATIC (newdecl) = TREE_STATIC (olddecl); + DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl); + /* An extern decl does not override previous storage class. */ + TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); + } + else + { + TREE_STATIC (olddecl) = TREE_STATIC (newdecl); + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + } - If the PARM_DECL already exists, return it, else create it. It's an - integer_type_node argument for the master function that implements a - subroutine or function with more than one entrypoint and is bound at - run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for - first ENTRY statement, and so on). */ + /* If either decl says `inline', this fn is inline, + unless its definition was passed already. */ + if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0) + DECL_INLINE (olddecl) = 1; + DECL_INLINE (newdecl) = DECL_INLINE (olddecl); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -tree -ffecom_which_entrypoint_decl () -{ - assert (ffecom_which_entrypoint_decl_ != NULL_TREE); + /* Get rid of any built-in function if new arg types don't match it + or if we have a function definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl) + && (!types_match || new_is_definition)) + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + DECL_BUILT_IN (olddecl) = 0; + } - return ffecom_which_entrypoint_decl_; -} + /* If redeclaring a builtin function, and not a definition, + it stays built in. + Also preserve various other info from the definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition) + { + if (DECL_BUILT_IN (olddecl)) + { + DECL_BUILT_IN (newdecl) = 1; + DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl); + } + else + DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl); -#endif - -/* The following sections consists of private and public functions - that have the same names and perform roughly the same functions - as counterparts in the C front end. Changes in the C front end - might affect how things should be done here. Only functions - needed by the back end should be public here; the rest should - be private (static in the C sense). Functions needed by other - g77 front-end modules should be accessed by them via public - ffecom_* names, which should themselves call private versions - in this section so the private versions are easy to recognize - when upgrading to a new gcc and finding interesting changes - in the front end. + DECL_RESULT (newdecl) = DECL_RESULT (olddecl); + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl); + DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl); + } - Functions named after rule "foo:" in c-parse.y are named - "bison_rule_foo_" so they are easy to find. */ + /* Copy most of the decl-specific fields of NEWDECL into OLDDECL. + But preserve olddecl's DECL_UID. */ + { + register unsigned olddecl_uid = DECL_UID (olddecl); -#if FFECOM_targetCURRENT == FFECOM_targetGCC + memcpy ((char *) olddecl + sizeof (struct tree_common), + (char *) newdecl + sizeof (struct tree_common), + sizeof (struct tree_decl) - sizeof (struct tree_common)); + DECL_UID (olddecl) = olddecl_uid; + } -static void -bison_rule_compstmt_ () -{ - emit_line_note (input_filename, lineno); - expand_end_bindings (getdecls (), 1, 1); - poplevel (1, 1, 0); - pop_momentary (); + return 1; } +/* Finish processing of a declaration; + install its initial value. + If the length of an array type is not known before, + it must be determined now, from the initial value, or it is an error. */ + static void -bison_rule_pushlevel_ () +finish_decl (tree decl, tree init, bool is_top_level) { - emit_line_note (input_filename, lineno); - pushlevel (0); - clear_last_expr (); - push_momentary (); - expand_start_bindings (0); -} + register tree type = TREE_TYPE (decl); + int was_incomplete = (DECL_SIZE (decl) == 0); + int temporary = allocation_temporary_p (); + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; -/* Return a definition for a builtin function named NAME and whose data type - is TYPE. TYPE should be a function type with argument types. - FUNCTION_CODE tells later passes how to compile calls to this function. - See tree.h for its possible values. + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); - If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, - the name to be called if we can't opencode the function. */ + if (TREE_CODE (decl) == PARM_DECL) + assert (init == NULL_TREE); + /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it + overlaps DECL_ARG_TYPE. */ + else if (init == NULL_TREE) + assert (DECL_INITIAL (decl) == NULL_TREE); + else + assert (DECL_INITIAL (decl) == error_mark_node); -static tree -builtin_function (const char *name, tree type, - enum built_in_function function_code, - const char *library_name) -{ - tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - if (library_name) - DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); - make_decl_rtl (decl, NULL_PTR, 1); - pushdecl (decl); - if (function_code != NOT_BUILT_IN) + if (init != NULL_TREE) { - DECL_BUILT_IN (decl) = 1; - DECL_FUNCTION_CODE (decl) = function_code; + if (TREE_CODE (decl) != TYPE_DECL) + DECL_INITIAL (decl) = init; + else + { + /* typedef foo = bar; store the type of bar as the type of foo. */ + TREE_TYPE (decl) = TREE_TYPE (init); + DECL_INITIAL (decl) = init = 0; + } } - return decl; -} - -/* Handle when a new declaration NEWDECL - has the same name as an old one OLDDECL - in the same binding contour. - Prints an error message if appropriate. + /* Pop back to the obstack that is current for this binding level. This is + because MAXINDEX, rtl, etc. to be made below must go in the permanent + obstack. But don't discard the temporary data yet. */ + pop_obstacks (); - If safely possible, alter OLDDECL to look like NEWDECL, and return 1. - Otherwise, return 0. */ + /* Deduce size of array from initialization, if not already known */ -static int -duplicate_decls (tree newdecl, tree olddecl) -{ - int types_match = 1; - int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL - && DECL_INITIAL (newdecl) != 0); - tree oldtype = TREE_TYPE (olddecl); - tree newtype = TREE_TYPE (newdecl); + if (TREE_CODE (type) == ARRAY_TYPE + && TYPE_DOMAIN (type) == 0 + && TREE_CODE (decl) != TYPE_DECL) + { + assert (top_level); + assert (was_incomplete); - if (olddecl == newdecl) - return 1; + layout_decl (decl, 0); + } - if (TREE_CODE (newtype) == ERROR_MARK - || TREE_CODE (oldtype) == ERROR_MARK) - types_match = 0; + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == NULL_TREE + && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + layout_decl (decl, 0); - /* New decl is completely inconsistent with the old one => - tell caller to replace the old one. - This is always an error except in the case of shadowing a builtin. */ - if (TREE_CODE (olddecl) != TREE_CODE (newdecl)) - return 0; + if (DECL_SIZE (decl) == NULL_TREE + && (TREE_STATIC (decl) + ? + /* A static variable with an incomplete type is an error if it is + initialized. Also if it is not file scope. Otherwise, let it + through, but if it is not `extern' then it may cause an error + message later. */ + (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0) + : + /* An automatic variable with an incomplete type is an error. */ + !DECL_EXTERNAL (decl))) + { + assert ("storage size not known" == NULL); + abort (); + } - /* For real parm decl following a forward decl, - return 1 so old decl will be reused. */ - if (types_match && TREE_CODE (newdecl) == PARM_DECL - && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl)) - return 1; + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && (DECL_SIZE (decl) != 0) + && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) + { + assert ("storage size not constant" == NULL); + abort (); + } + } - /* The new declaration is the same kind of object as the old one. - The declarations may partially match. Print warnings if they don't - match enough. Ultimately, copy most of the information from the new - decl to the old one, and keep using the old one. */ + /* Output the assembler code and/or RTL code for variables and functions, + unless the type is an undefined structure or union. If not, it will get + done when the type is completed. */ - if (TREE_CODE (olddecl) == FUNCTION_DECL - && DECL_BUILT_IN (olddecl)) + if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) { - /* A function declaration for a built-in function. */ - if (!TREE_PUBLIC (newdecl)) - return 0; - else if (!types_match) - { - /* Accept the return type of the new declaration if same modes. */ - tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl)); - tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl)); + rest_of_decl_compilation (decl, NULL, + DECL_CONTEXT (decl) == 0, + 0); - /* Make sure we put the new type in the same obstack as the old ones. - If the old types are not both in the same obstack, use the - permanent one. */ - if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) - push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); - else + if (DECL_CONTEXT (decl) != 0) + { + /* Recompute the RTL of a local array now if it used to be an + incomplete type. */ + if (was_incomplete + && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) { - push_obstacks_nochange (); - end_temporary_allocation (); + /* If we used it already as memory, it must stay in memory. */ + TREE_ADDRESSABLE (decl) = TREE_USED (decl); + /* If it's still incomplete now, no init will save it. */ + if (DECL_SIZE (decl) == 0) + DECL_INITIAL (decl) = 0; + expand_decl (decl); } + /* Compute and store the initial value. */ + if (TREE_CODE (decl) != FUNCTION_DECL) + expand_decl_init (decl); + } + } + else if (TREE_CODE (decl) == TYPE_DECL) + { + rest_of_decl_compilation (decl, NULL_PTR, + DECL_CONTEXT (decl) == 0, + 0); + } - if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype)) + /* This test used to include TREE_PERMANENT, however, we have the same + problem with initializers at the function level. Such initializers get + saved until the end of the function on the momentary_obstack. */ + if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) + && temporary + /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with + DECL_ARG_TYPE. */ + && TREE_CODE (decl) != PARM_DECL) + { + /* We need to remember that this array HAD an initialization, but + discard the actual temporary nodes, since we can't have a permanent + node keep pointing to them. */ + /* We make an exception for inline functions, since it's normal for a + local extern redeclaration of an inline function to have a copy of + the top-level decl's DECL_INLINE. */ + if ((DECL_INITIAL (decl) != 0) + && (DECL_INITIAL (decl) != error_mark_node)) + { + /* If this is a const variable, then preserve the + initializer instead of discarding it so that we can optimize + references to it. */ + /* This test used to include TREE_STATIC, but this won't be set + for function level initializers. */ + if (TREE_READONLY (decl)) { - /* Function types may be shared, so we can't just modify - the return type of olddecl's function type. */ - tree newtype - = build_function_type (newreturntype, - TYPE_ARG_TYPES (TREE_TYPE (olddecl))); + preserve_initializer (); + /* Hack? Set the permanent bit for something that is + permanent, but not on the permenent obstack, so as to + convince output_constant_def to make its rtl on the + permanent obstack. */ + TREE_PERMANENT (DECL_INITIAL (decl)) = 1; - types_match = 1; - if (types_match) - TREE_TYPE (olddecl) = newtype; + /* The initializer and DECL must have the same (or equivalent + types), but if the initializer is a STRING_CST, its type + might not be on the right obstack, so copy the type + of DECL. */ + TREE_TYPE (DECL_INITIAL (decl)) = type; } - - pop_obstacks (); + else + DECL_INITIAL (decl) = error_mark_node; } - if (!types_match) - return 0; } - else if (TREE_CODE (olddecl) == FUNCTION_DECL - && DECL_SOURCE_LINE (olddecl) == 0) + + /* If requested, warn about definitions of large data objects. */ + + if (warn_larger_than + && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) + && !DECL_EXTERNAL (decl)) { - /* A function declaration for a predeclared function - that isn't actually built in. */ - if (!TREE_PUBLIC (newdecl)) - return 0; - else if (!types_match) + register tree decl_size = DECL_SIZE (decl); + + if (decl_size && TREE_CODE (decl_size) == INTEGER_CST) { - /* If the types don't match, preserve volatility indication. - Later on, we will discard everything else about the - default declaration. */ - TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); + unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT; + + if (units > larger_than_size) + warning_with_decl (decl, "size of `%s' is %u bytes", units); } } - /* Copy all the DECL_... slots specified in the new decl - except for any that we copy here from the old type. + /* If we have gone back from temporary to permanent allocation, actually + free the temporary space that we no longer need. */ + if (temporary && !allocation_temporary_p ()) + permanent_allocation (0); - Past this point, we don't change OLDTYPE and NEWTYPE - even if we change the types of NEWDECL and OLDDECL. */ + /* At the end of a declaration, throw away any variable type sizes of types + defined inside that declaration. There is no use computing them in the + following function definition. */ + if (current_binding_level == global_binding_level) + get_pending_sizes (); +} - if (types_match) - { - /* Make sure we put the new type in the same obstack as the old ones. - If the old types are not both in the same obstack, use the permanent - one. */ - if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) - push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); - else - { - push_obstacks_nochange (); - end_temporary_allocation (); - } +/* Finish up a function declaration and compile that function + all the way to assembler language output. The free the storage + for the function definition. - /* Merge the data types specified in the two decls. */ - if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl)) - TREE_TYPE (newdecl) - = TREE_TYPE (olddecl) - = TREE_TYPE (newdecl); + This is called after parsing the body of the function definition. - /* Lay the type out, unless already done. */ - if (oldtype != TREE_TYPE (newdecl)) - { - if (TREE_TYPE (newdecl) != error_mark_node) - layout_type (TREE_TYPE (newdecl)); - if (TREE_CODE (newdecl) != FUNCTION_DECL - && TREE_CODE (newdecl) != TYPE_DECL - && TREE_CODE (newdecl) != CONST_DECL) - layout_decl (newdecl, 0); - } + NESTED is nonzero if the function being finished is nested in another. */ + +static void +finish_function (int nested) +{ + register tree fndecl = current_function_decl; + + assert (fndecl != NULL_TREE); + if (TREE_CODE (fndecl) != ERROR_MARK) + { + if (nested) + assert (DECL_CONTEXT (fndecl) != NULL_TREE); else - { - /* Since the type is OLDDECL's, make OLDDECL's size go with. */ - DECL_SIZE (newdecl) = DECL_SIZE (olddecl); - if (TREE_CODE (olddecl) != FUNCTION_DECL) - if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) - DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); - } + assert (DECL_CONTEXT (fndecl) == NULL_TREE); + } - /* Keep the old rtl since we can safely use it. */ - DECL_RTL (newdecl) = DECL_RTL (olddecl); +/* TREE_READONLY (fndecl) = 1; + This caused &foo to be of type ptr-to-const-function + which then got a warning when stored in a ptr-to-function variable. */ - /* Merge the type qualifiers. */ - if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl) - && !TREE_THIS_VOLATILE (newdecl)) - TREE_THIS_VOLATILE (olddecl) = 0; - if (TREE_READONLY (newdecl)) - TREE_READONLY (olddecl) = 1; - if (TREE_THIS_VOLATILE (newdecl)) - { - TREE_THIS_VOLATILE (olddecl) = 1; - if (TREE_CODE (newdecl) == VAR_DECL) - make_var_volatile (newdecl); - } + poplevel (1, 0, 1); - /* Keep source location of definition rather than declaration. - Likewise, keep decl at outer scope. */ - if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0) - || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0)) - { - DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl); - DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl); + if (TREE_CODE (fndecl) != ERROR_MARK) + { + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; - if (DECL_CONTEXT (olddecl) == 0 - && TREE_CODE (newdecl) != FUNCTION_DECL) - DECL_CONTEXT (newdecl) = 0; - } + /* Must mark the RESULT_DECL as being in this function. */ - /* Merge the unused-warning information. */ - if (DECL_IN_SYSTEM_HEADER (olddecl)) - DECL_IN_SYSTEM_HEADER (newdecl) = 1; - else if (DECL_IN_SYSTEM_HEADER (newdecl)) - DECL_IN_SYSTEM_HEADER (olddecl) = 1; + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; - /* Merge the initialization information. */ - if (DECL_INITIAL (newdecl) == 0) - DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + /* Obey `register' declarations if `setjmp' is called in this fn. */ + /* Generate rtl for function exit. */ + expand_function_end (input_filename, lineno, 0); - /* Merge the section attribute. - We want to issue an error if the sections conflict but that must be - done later in decl_attributes since we are called before attributes - are assigned. */ - if (DECL_SECTION_NAME (newdecl) == NULL_TREE) - DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl); + /* So we can tell if jump_optimize sets it to 1. */ + can_reach_end = 0; -#if BUILT_FOR_270 - if (TREE_CODE (newdecl) == FUNCTION_DECL) - { - DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl); - DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl); - } -#endif + /* Run the optimizers and output the assembler code for this function. */ + rest_of_compilation (fndecl); + } - pop_obstacks (); + /* Free all the tree nodes making up this function. */ + /* Switch back to allocating nodes permanently until we start another + function. */ + if (!nested) + permanent_allocation (1); + + if (TREE_CODE (fndecl) != ERROR_MARK + && !nested + && DECL_SAVED_INSNS (fndecl) == 0) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + /* For a nested function, this is done in pop_f_function_context. */ + /* If rest_of_compilation set this to 0, leave it 0. */ + if (DECL_INITIAL (fndecl) != 0) + DECL_INITIAL (fndecl) = error_mark_node; + DECL_ARGUMENTS (fndecl) = 0; } - /* If cannot merge, then use the new type and qualifiers, - and don't preserve the old rtl. */ - else + + if (!nested) { - TREE_TYPE (olddecl) = TREE_TYPE (newdecl); - TREE_READONLY (olddecl) = TREE_READONLY (newdecl); - TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl); - TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl); + /* Let the error reporting routines know that we're outside a function. + For a nested function, this value is used in pop_c_function_context + and then reset via pop_function_context. */ + ffecom_outer_function_decl_ = current_function_decl = NULL; } +} - /* Merge the storage class information. */ - /* For functions, static overrides non-static. */ - if (TREE_CODE (newdecl) == FUNCTION_DECL) +/* Plug-in replacement for identifying the name of a decl and, for a + function, what we call it in diagnostics. For now, "program unit" + should suffice, since it's a bit of a hassle to figure out which + of several kinds of things it is. Note that it could conceivably + be a statement function, which probably isn't really a program unit + per se, but if that comes up, it should be easy to check (being a + nested function and all). */ + +static char * +lang_printable_name (tree decl, int v) +{ + /* Just to keep GCC quiet about the unused variable. + In theory, differing values of V should produce different + output. */ + switch (v) { - TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl); - /* This is since we don't automatically - copy the attributes of NEWDECL into OLDDECL. */ - TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); - /* If this clears `static', clear it in the identifier too. */ - if (! TREE_PUBLIC (olddecl)) - TREE_PUBLIC (DECL_NAME (olddecl)) = 0; + default: + if (TREE_CODE (decl) == ERROR_MARK) + return "erroneous code"; + return IDENTIFIER_POINTER (DECL_NAME (decl)); } - if (DECL_EXTERNAL (newdecl)) +} + +/* g77's function to print out name of current function that caused + an error. */ + +#if BUILT_FOR_270 +void +lang_print_error_function (file) + char *file; +{ + static ffeglobal last_g = NULL; + static ffesymbol last_s = NULL; + ffeglobal g; + ffesymbol s; + const char *kind; + + if ((ffecom_primary_entry_ == NULL) + || (ffesymbol_global (ffecom_primary_entry_) == NULL)) { - TREE_STATIC (newdecl) = TREE_STATIC (olddecl); - DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl); - /* An extern decl does not override previous storage class. */ - TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); + g = NULL; + s = NULL; + kind = NULL; } else { - TREE_STATIC (olddecl) = TREE_STATIC (newdecl); - TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); - } + g = ffesymbol_global (ffecom_primary_entry_); + if (ffecom_nested_entry_ == NULL) + { + s = ffecom_primary_entry_; + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindFUNCTION: + kind = "function"; + break; - /* If either decl says `inline', this fn is inline, - unless its definition was passed already. */ - if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0) - DECL_INLINE (olddecl) = 1; - DECL_INLINE (newdecl) = DECL_INLINE (olddecl); + case FFEINFO_kindSUBROUTINE: + kind = "subroutine"; + break; - /* Get rid of any built-in function if new arg types don't match it - or if we have a function definition. */ - if (TREE_CODE (newdecl) == FUNCTION_DECL - && DECL_BUILT_IN (olddecl) - && (!types_match || new_is_definition)) - { - TREE_TYPE (olddecl) = TREE_TYPE (newdecl); - DECL_BUILT_IN (olddecl) = 0; + case FFEINFO_kindPROGRAM: + kind = "program"; + break; + + case FFEINFO_kindBLOCKDATA: + kind = "block-data"; + break; + + default: + kind = ffeinfo_kind_message (ffesymbol_kind (s)); + break; + } + } + else + { + s = ffecom_nested_entry_; + kind = "statement function"; + } } - /* If redeclaring a builtin function, and not a definition, - it stays built in. - Also preserve various other info from the definition. */ - if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition) + if ((last_g != g) || (last_s != s)) { - if (DECL_BUILT_IN (olddecl)) + if (file) + fprintf (stderr, "%s: ", file); + + if (s == NULL) + fprintf (stderr, "Outside of any program unit:\n"); + else { - DECL_BUILT_IN (newdecl) = 1; - DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl); + const char *name = ffesymbol_text (s); + + fprintf (stderr, "In %s `%s':\n", kind, name); } - else - DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl); - DECL_RESULT (newdecl) = DECL_RESULT (olddecl); - DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); - DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl); - DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl); + last_g = g; + last_s = s; } +} +#endif - /* Copy most of the decl-specific fields of NEWDECL into OLDDECL. - But preserve olddecl's DECL_UID. */ - { - register unsigned olddecl_uid = DECL_UID (olddecl); +/* Similar to `lookup_name' but look only at current binding level. */ - memcpy ((char *) olddecl + sizeof (struct tree_common), - (char *) newdecl + sizeof (struct tree_common), - sizeof (struct tree_decl) - sizeof (struct tree_common)); - DECL_UID (olddecl) = olddecl_uid; - } +static tree +lookup_name_current_level (tree name) +{ + register tree t; - return 1; + if (current_binding_level == global_binding_level) + return IDENTIFIER_GLOBAL_VALUE (name); + + if (IDENTIFIER_LOCAL_VALUE (name) == 0) + return 0; + + for (t = current_binding_level->names; t; t = TREE_CHAIN (t)) + if (DECL_NAME (t) == name) + break; + + return t; } -/* Finish processing of a declaration; - install its initial value. - If the length of an array type is not known before, - it must be determined now, from the initial value, or it is an error. */ +/* Create a new `struct binding_level'. */ -static void -finish_decl (tree decl, tree init, bool is_top_level) +static struct binding_level * +make_binding_level () { - register tree type = TREE_TYPE (decl); - int was_incomplete = (DECL_SIZE (decl) == 0); - int temporary = allocation_temporary_p (); - bool at_top_level = (current_binding_level == global_binding_level); - bool top_level = is_top_level || at_top_level; + /* NOSTRICT */ + return (struct binding_level *) xmalloc (sizeof (struct binding_level)); +} - /* Caller should pass TRUE for is_top_level only if we wouldn't be at top - level anyway. */ - assert (!is_top_level || !at_top_level); +/* Save and restore the variables in this file and elsewhere + that keep track of the progress of compilation of the current function. + Used for nested functions. */ - if (TREE_CODE (decl) == PARM_DECL) - assert (init == NULL_TREE); - /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it - overlaps DECL_ARG_TYPE. */ - else if (init == NULL_TREE) - assert (DECL_INITIAL (decl) == NULL_TREE); - else - assert (DECL_INITIAL (decl) == error_mark_node); +struct f_function +{ + struct f_function *next; + tree named_labels; + tree shadowed_labels; + struct binding_level *binding_level; +}; - if (init != NULL_TREE) - { - if (TREE_CODE (decl) != TYPE_DECL) - DECL_INITIAL (decl) = init; - else - { - /* typedef foo = bar; store the type of bar as the type of foo. */ - TREE_TYPE (decl) = TREE_TYPE (init); - DECL_INITIAL (decl) = init = 0; - } - } +struct f_function *f_function_chain; - /* Pop back to the obstack that is current for this binding level. This is - because MAXINDEX, rtl, etc. to be made below must go in the permanent - obstack. But don't discard the temporary data yet. */ - pop_obstacks (); +/* Restore the variables used during compilation of a C function. */ - /* Deduce size of array from initialization, if not already known */ +static void +pop_f_function_context () +{ + struct f_function *p = f_function_chain; + tree link; - if (TREE_CODE (type) == ARRAY_TYPE - && TYPE_DOMAIN (type) == 0 - && TREE_CODE (decl) != TYPE_DECL) - { - assert (top_level); - assert (was_incomplete); + /* Bring back all the labels that were shadowed. */ + for (link = shadowed_labels; link; link = TREE_CHAIN (link)) + if (DECL_NAME (TREE_VALUE (link)) != 0) + IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) + = TREE_VALUE (link); - layout_decl (decl, 0); + if (current_function_decl != error_mark_node + && DECL_SAVED_INSNS (current_function_decl) == 0) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + DECL_INITIAL (current_function_decl) = error_mark_node; + DECL_ARGUMENTS (current_function_decl) = 0; } - if (TREE_CODE (decl) == VAR_DECL) - { - if (DECL_SIZE (decl) == NULL_TREE - && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) - layout_decl (decl, 0); + pop_function_context (); - if (DECL_SIZE (decl) == NULL_TREE - && (TREE_STATIC (decl) - ? - /* A static variable with an incomplete type is an error if it is - initialized. Also if it is not file scope. Otherwise, let it - through, but if it is not `extern' then it may cause an error - message later. */ - (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0) - : - /* An automatic variable with an incomplete type is an error. */ - !DECL_EXTERNAL (decl))) - { - assert ("storage size not known" == NULL); - abort (); - } + f_function_chain = p->next; - if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) - && (DECL_SIZE (decl) != 0) - && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) - { - assert ("storage size not constant" == NULL); - abort (); - } - } + named_labels = p->named_labels; + shadowed_labels = p->shadowed_labels; + current_binding_level = p->binding_level; - /* Output the assembler code and/or RTL code for variables and functions, - unless the type is an undefined structure or union. If not, it will get - done when the type is completed. */ + free (p); +} - if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) - { - rest_of_decl_compilation (decl, NULL, - DECL_CONTEXT (decl) == 0, - 0); +/* Save and reinitialize the variables + used during compilation of a C function. */ - if (DECL_CONTEXT (decl) != 0) - { - /* Recompute the RTL of a local array now if it used to be an - incomplete type. */ - if (was_incomplete - && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) - { - /* If we used it already as memory, it must stay in memory. */ - TREE_ADDRESSABLE (decl) = TREE_USED (decl); - /* If it's still incomplete now, no init will save it. */ - if (DECL_SIZE (decl) == 0) - DECL_INITIAL (decl) = 0; - expand_decl (decl); - } - /* Compute and store the initial value. */ - if (TREE_CODE (decl) != FUNCTION_DECL) - expand_decl_init (decl); - } - } - else if (TREE_CODE (decl) == TYPE_DECL) - { - rest_of_decl_compilation (decl, NULL_PTR, - DECL_CONTEXT (decl) == 0, - 0); - } +static void +push_f_function_context () +{ + struct f_function *p + = (struct f_function *) xmalloc (sizeof (struct f_function)); - /* This test used to include TREE_PERMANENT, however, we have the same - problem with initializers at the function level. Such initializers get - saved until the end of the function on the momentary_obstack. */ - if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) - && temporary - /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with - DECL_ARG_TYPE. */ - && TREE_CODE (decl) != PARM_DECL) - { - /* We need to remember that this array HAD an initialization, but - discard the actual temporary nodes, since we can't have a permanent - node keep pointing to them. */ - /* We make an exception for inline functions, since it's normal for a - local extern redeclaration of an inline function to have a copy of - the top-level decl's DECL_INLINE. */ - if ((DECL_INITIAL (decl) != 0) - && (DECL_INITIAL (decl) != error_mark_node)) - { - /* If this is a const variable, then preserve the - initializer instead of discarding it so that we can optimize - references to it. */ - /* This test used to include TREE_STATIC, but this won't be set - for function level initializers. */ - if (TREE_READONLY (decl)) - { - preserve_initializer (); - /* Hack? Set the permanent bit for something that is - permanent, but not on the permenent obstack, so as to - convince output_constant_def to make its rtl on the - permanent obstack. */ - TREE_PERMANENT (DECL_INITIAL (decl)) = 1; + push_function_context (); + + p->next = f_function_chain; + f_function_chain = p; + + p->named_labels = named_labels; + p->shadowed_labels = shadowed_labels; + p->binding_level = current_binding_level; +} - /* The initializer and DECL must have the same (or equivalent - types), but if the initializer is a STRING_CST, its type - might not be on the right obstack, so copy the type - of DECL. */ - TREE_TYPE (DECL_INITIAL (decl)) = type; - } - else - DECL_INITIAL (decl) = error_mark_node; - } - } +static void +push_parm_decl (tree parm) +{ + int old_immediate_size_expand = immediate_size_expand; - /* If requested, warn about definitions of large data objects. */ + /* Don't try computing parm sizes now -- wait till fn is called. */ - if (warn_larger_than - && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) - && !DECL_EXTERNAL (decl)) - { - register tree decl_size = DECL_SIZE (decl); + immediate_size_expand = 0; - if (decl_size && TREE_CODE (decl_size) == INTEGER_CST) - { - unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT; + push_obstacks_nochange (); - if (units > larger_than_size) - warning_with_decl (decl, "size of `%s' is %u bytes", units); - } - } + /* Fill in arg stuff. */ - /* If we have gone back from temporary to permanent allocation, actually - free the temporary space that we no longer need. */ - if (temporary && !allocation_temporary_p ()) - permanent_allocation (0); + DECL_ARG_TYPE (parm) = TREE_TYPE (parm); + DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm); + TREE_READONLY (parm) = 1; /* All implementation args are read-only. */ - /* At the end of a declaration, throw away any variable type sizes of types - defined inside that declaration. There is no use computing them in the - following function definition. */ - if (current_binding_level == global_binding_level) - get_pending_sizes (); + parm = pushdecl (parm); + + immediate_size_expand = old_immediate_size_expand; + + finish_decl (parm, NULL_TREE, FALSE); } -/* Finish up a function declaration and compile that function - all the way to assembler language output. The free the storage - for the function definition. +/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */ - This is called after parsing the body of the function definition. +static tree +pushdecl_top_level (x) + tree x; +{ + register tree t; + register struct binding_level *b = current_binding_level; + register tree f = current_function_decl; - NESTED is nonzero if the function being finished is nested in another. */ + current_binding_level = global_binding_level; + current_function_decl = NULL_TREE; + t = pushdecl (x); + current_binding_level = b; + current_function_decl = f; + return t; +} + +/* Store the list of declarations of the current level. + This is done for the parameter declarations of a function being defined, + after they are modified in the light of any missing parameters. */ + +static tree +storedecls (decls) + tree decls; +{ + return current_binding_level->names = decls; +} + +/* Store the parameter declarations into the current function declaration. + This is called after parsing the parameter declarations, before + digesting the body of the function. + + For an old-style definition, modify the function's type + to specify at least the number of arguments. */ static void -finish_function (int nested) +store_parm_decls (int is_main_program UNUSED) { register tree fndecl = current_function_decl; - assert (fndecl != NULL_TREE); - if (TREE_CODE (fndecl) != ERROR_MARK) - { - if (nested) - assert (DECL_CONTEXT (fndecl) != NULL_TREE); - else - assert (DECL_CONTEXT (fndecl) == NULL_TREE); - } + if (fndecl == error_mark_node) + return; -/* TREE_READONLY (fndecl) = 1; - This caused &foo to be of type ptr-to-const-function - which then got a warning when stored in a ptr-to-function variable. */ + /* This is a chain of PARM_DECLs from old-style parm declarations. */ + DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ())); - poplevel (1, 0, 1); + /* Initialize the RTL code for the function. */ - if (TREE_CODE (fndecl) != ERROR_MARK) - { - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + init_function_start (fndecl, input_filename, lineno); - /* Must mark the RESULT_DECL as being in this function. */ + /* Set up parameters and prepare for return, for the function. */ - DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + expand_function_start (fndecl, 0); +} - /* Obey `register' declarations if `setjmp' is called in this fn. */ - /* Generate rtl for function exit. */ - expand_function_end (input_filename, lineno, 0); +static tree +start_decl (tree decl, bool is_top_level) +{ + register tree tem; + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; - /* So we can tell if jump_optimize sets it to 1. */ - can_reach_end = 0; + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); - /* Run the optimizers and output the assembler code for this function. */ - rest_of_compilation (fndecl); + /* The corresponding pop_obstacks is in finish_decl. */ + push_obstacks_nochange (); + + if (DECL_INITIAL (decl) != NULL_TREE) + { + assert (DECL_INITIAL (decl) == error_mark_node); + assert (!DECL_EXTERNAL (decl)); } + else if (top_level) + assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1); - /* Free all the tree nodes making up this function. */ - /* Switch back to allocating nodes permanently until we start another - function. */ - if (!nested) - permanent_allocation (1); + /* For Fortran, we by default put things in .common when possible. */ + DECL_COMMON (decl) = 1; - if (TREE_CODE (fndecl) != ERROR_MARK - && !nested - && DECL_SAVED_INSNS (fndecl) == 0) + /* Add this decl to the current binding level. TEM may equal DECL or it may + be a previous decl of the same name. */ + if (is_top_level) + tem = pushdecl_top_level (decl); + else + tem = pushdecl (decl); + + /* For a local variable, define the RTL now. */ + if (!top_level + /* But not if this is a duplicate decl and we preserved the rtl from the + previous one (which may or may not happen). */ + && DECL_RTL (tem) == 0) { - /* Stop pointing to the local nodes about to be freed. */ - /* But DECL_INITIAL must remain nonzero so we know this was an actual - function definition. */ - /* For a nested function, this is done in pop_f_function_context. */ - /* If rest_of_compilation set this to 0, leave it 0. */ - if (DECL_INITIAL (fndecl) != 0) - DECL_INITIAL (fndecl) = error_mark_node; - DECL_ARGUMENTS (fndecl) = 0; + if (TYPE_SIZE (TREE_TYPE (tem)) != 0) + expand_decl (tem); + else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE + && DECL_INITIAL (tem) != 0) + expand_decl (tem); } - if (!nested) + if (DECL_INITIAL (tem) != NULL_TREE) { - /* Let the error reporting routines know that we're outside a function. - For a nested function, this value is used in pop_c_function_context - and then reset via pop_function_context. */ - ffecom_outer_function_decl_ = current_function_decl = NULL; + /* When parsing and digesting the initializer, use temporary storage. + Do this even if we will ignore the value. */ + if (at_top_level) + temporary_allocation (); } + + return tem; } -/* Plug-in replacement for identifying the name of a decl and, for a - function, what we call it in diagnostics. For now, "program unit" - should suffice, since it's a bit of a hassle to figure out which - of several kinds of things it is. Note that it could conceivably - be a statement function, which probably isn't really a program unit - per se, but if that comes up, it should be easy to check (being a - nested function and all). */ +/* Create the FUNCTION_DECL for a function definition. + DECLSPECS and DECLARATOR are the parts of the declaration; + they describe the function's name and the type it returns, + but twisted together in a fashion that parallels the syntax of C. -static char * -lang_printable_name (tree decl, int v) -{ - /* Just to keep GCC quiet about the unused variable. - In theory, differing values of V should produce different - output. */ - switch (v) - { - default: - if (TREE_CODE (decl) == ERROR_MARK) - return "erroneous code"; - return IDENTIFIER_POINTER (DECL_NAME (decl)); - } -} + This function creates a binding context for the function body + as well as setting up the FUNCTION_DECL in current_function_decl. -/* g77's function to print out name of current function that caused - an error. */ + Returns 1 on success. If the DECLARATOR is not suitable for a function + (it defines a datum instead), we return 0, which tells + yyparse to report a parse error. -#if BUILT_FOR_270 -void -lang_print_error_function (file) - char *file; + NESTED is nonzero for a function nested within another function. */ + +static void +start_function (tree name, tree type, int nested, int public) { - static ffeglobal last_g = NULL; - static ffesymbol last_s = NULL; - ffeglobal g; - ffesymbol s; - const char *kind; + tree decl1; + tree restype; + int old_immediate_size_expand = immediate_size_expand; - if ((ffecom_primary_entry_ == NULL) - || (ffesymbol_global (ffecom_primary_entry_) == NULL)) + named_labels = 0; + shadowed_labels = 0; + + /* Don't expand any sizes in the return type of the function. */ + immediate_size_expand = 0; + + if (nested) { - g = NULL; - s = NULL; - kind = NULL; + assert (!public); + assert (current_function_decl != NULL_TREE); + assert (DECL_CONTEXT (current_function_decl) == NULL_TREE); + } + else + { + assert (current_function_decl == NULL_TREE); } + + if (TREE_CODE (type) == ERROR_MARK) + decl1 = current_function_decl = error_mark_node; else { - g = ffesymbol_global (ffecom_primary_entry_); - if (ffecom_nested_entry_ == NULL) - { - s = ffecom_primary_entry_; - switch (ffesymbol_kind (s)) - { - case FFEINFO_kindFUNCTION: - kind = "function"; - break; + decl1 = build_decl (FUNCTION_DECL, + name, + type); + TREE_PUBLIC (decl1) = public ? 1 : 0; + if (nested) + DECL_INLINE (decl1) = 1; + TREE_STATIC (decl1) = 1; + DECL_EXTERNAL (decl1) = 0; - case FFEINFO_kindSUBROUTINE: - kind = "subroutine"; - break; + announce_function (decl1); - case FFEINFO_kindPROGRAM: - kind = "program"; - break; + /* Make the init_value nonzero so pushdecl knows this is not tentative. + error_mark_node is replaced below (in poplevel) with the BLOCK. */ + DECL_INITIAL (decl1) = error_mark_node; - case FFEINFO_kindBLOCKDATA: - kind = "block-data"; - break; + /* Record the decl so that the function name is defined. If we already have + a decl for this name, and it is a FUNCTION_DECL, use the old decl. */ - default: - kind = ffeinfo_kind_message (ffesymbol_kind (s)); - break; - } - } - else - { - s = ffecom_nested_entry_; - kind = "statement function"; - } + current_function_decl = pushdecl (decl1); } - if ((last_g != g) || (last_s != s)) - { - if (file) - fprintf (stderr, "%s: ", file); + if (!nested) + ffecom_outer_function_decl_ = current_function_decl; - if (s == NULL) - fprintf (stderr, "Outside of any program unit:\n"); - else - { - const char *name = ffesymbol_text (s); + pushlevel (0); + current_binding_level->prep_state = 2; - fprintf (stderr, "In %s `%s':\n", kind, name); - } + if (TREE_CODE (current_function_decl) != ERROR_MARK) + { + make_function_rtl (current_function_decl); - last_g = g; - last_s = s; + restype = TREE_TYPE (TREE_TYPE (current_function_decl)); + DECL_RESULT (current_function_decl) + = build_decl (RESULT_DECL, NULL_TREE, restype); } -} -#endif -/* Similar to `lookup_name' but look only at current binding level. */ + if (!nested) + /* Allocate further tree nodes temporarily during compilation of this + function only. */ + temporary_allocation (); -static tree -lookup_name_current_level (tree name) + if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK)) + TREE_ADDRESSABLE (current_function_decl) = 1; + + immediate_size_expand = old_immediate_size_expand; +} + +/* Here are the public functions the GNU back end needs. */ + +tree +convert (type, expr) + tree type, expr; { - register tree t; + register tree e = expr; + register enum tree_code code = TREE_CODE (type); - if (current_binding_level == global_binding_level) - return IDENTIFIER_GLOBAL_VALUE (name); + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + if (code == VOID_TYPE) + return build1 (CONVERT_EXPR, type, e); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))), + e); + if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) + return fold (convert_to_integer (type, e)); + if (code == POINTER_TYPE) + return fold (convert_to_pointer (type, e)); + if (code == REAL_TYPE) + return fold (convert_to_real (type, e)); + if (code == COMPLEX_TYPE) + return fold (convert_to_complex (type, e)); + if (code == RECORD_TYPE) + return fold (ffecom_convert_to_complex_ (type, e)); - if (IDENTIFIER_LOCAL_VALUE (name) == 0) - return 0; + assert ("conversion to non-scalar type requested" == NULL); + return error_mark_node; +} - for (t = current_binding_level->names; t; t = TREE_CHAIN (t)) - if (DECL_NAME (t) == name) - break; +/* integrate_decl_tree calls this function, but since we don't use the + DECL_LANG_SPECIFIC field, this is a no-op. */ - return t; +void +copy_lang_decl (node) + tree node UNUSED; +{ } -/* Create a new `struct binding_level'. */ +/* Return the list of declarations of the current level. + Note that this list is in reverse order unless/until + you nreverse it; and when you do nreverse it, you must + store the result back using `storedecls' or you will lose. */ -static struct binding_level * -make_binding_level () +tree +getdecls () { - /* NOSTRICT */ - return (struct binding_level *) xmalloc (sizeof (struct binding_level)); + return current_binding_level->names; } -/* Save and restore the variables in this file and elsewhere - that keep track of the progress of compilation of the current function. - Used for nested functions. */ +/* Nonzero if we are currently in the global binding level. */ -struct f_function +int +global_bindings_p () { - struct f_function *next; - tree named_labels; - tree shadowed_labels; - struct binding_level *binding_level; -}; + return current_binding_level == global_binding_level; +} -struct f_function *f_function_chain; +/* Print an error message for invalid use of an incomplete type. + VALUE is the expression that was used (or 0 if that isn't known) + and TYPE is the type that was invalid. */ -/* Restore the variables used during compilation of a C function. */ +void +incomplete_type_error (value, type) + tree value UNUSED; + tree type; +{ + if (TREE_CODE (type) == ERROR_MARK) + return; -static void -pop_f_function_context () + assert ("incomplete type?!?" == NULL); +} + +void +init_decl_processing () { - struct f_function *p = f_function_chain; - tree link; + malloc_init (); + ffe_init_0 (); +} - /* Bring back all the labels that were shadowed. */ - for (link = shadowed_labels; link; link = TREE_CHAIN (link)) - if (DECL_NAME (TREE_VALUE (link)) != 0) - IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) - = TREE_VALUE (link); +char * +init_parse (filename) + char *filename; +{ +#if BUILT_FOR_270 + extern void (*print_error_function) (char *); +#endif - if (current_function_decl != error_mark_node - && DECL_SAVED_INSNS (current_function_decl) == 0) + /* Open input file. */ + if (filename == 0 || !strcmp (filename, "-")) { - /* Stop pointing to the local nodes about to be freed. */ - /* But DECL_INITIAL must remain nonzero so we know this was an actual - function definition. */ - DECL_INITIAL (current_function_decl) = error_mark_node; - DECL_ARGUMENTS (current_function_decl) = 0; + finput = stdin; + filename = "stdin"; } + else + finput = fopen (filename, "r"); + if (finput == 0) + pfatal_with_name (filename); - pop_function_context (); +#ifdef IO_BUFFER_SIZE + setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); +#endif - f_function_chain = p->next; + /* Make identifier nodes long enough for the language-specific slots. */ + set_identifier_size (sizeof (struct lang_identifier)); + decl_printable_name = lang_printable_name; +#if BUILT_FOR_270 + print_error_function = lang_print_error_function; +#endif - named_labels = p->named_labels; - shadowed_labels = p->shadowed_labels; - current_binding_level = p->binding_level; + return filename; +} - free (p); +void +finish_parse () +{ + fclose (finput); +} + +/* Delete the node BLOCK from the current binding level. + This is used for the block inside a stmt expr ({...}) + so that the block can be reinserted where appropriate. */ + +static void +delete_block (block) + tree block; +{ + tree t; + if (current_binding_level->blocks == block) + current_binding_level->blocks = TREE_CHAIN (block); + for (t = current_binding_level->blocks; t;) + { + if (TREE_CHAIN (t) == block) + TREE_CHAIN (t) = TREE_CHAIN (block); + else + t = TREE_CHAIN (t); + } + TREE_CHAIN (block) = NULL; + /* Clear TREE_USED which is always set by poplevel. + The flag is set again if insert_block is called. */ + TREE_USED (block) = 0; +} + +void +insert_block (block) + tree block; +{ + TREE_USED (block) = 1; + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); +} + +int +lang_decode_option (argc, argv) + int argc; + char **argv; +{ + return ffe_decode_option (argc, argv); } -/* Save and reinitialize the variables - used during compilation of a C function. */ +/* used by print-tree.c */ -static void -push_f_function_context () +void +lang_print_xnode (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; { - struct f_function *p - = (struct f_function *) xmalloc (sizeof (struct f_function)); - - push_function_context (); +} - p->next = f_function_chain; - f_function_chain = p; +void +lang_finish () +{ + ffe_terminate_0 (); - p->named_labels = named_labels; - p->shadowed_labels = shadowed_labels; - p->binding_level = current_binding_level; + if (ffe_is_ffedebug ()) + malloc_pool_display (malloc_pool_image ()); } -static void -push_parm_decl (tree parm) +char * +lang_identify () { - int old_immediate_size_expand = immediate_size_expand; - - /* Don't try computing parm sizes now -- wait till fn is called. */ + return "f77"; +} - immediate_size_expand = 0; +void +lang_init_options () +{ + /* Set default options for Fortran. */ + flag_move_all_movables = 1; + flag_reduce_all_givs = 1; + flag_argument_noalias = 2; +} - push_obstacks_nochange (); +void +lang_init () +{ + /* If the file is output from cpp, it should contain a first line + `# 1 "real-filename"', and the current design of gcc (toplev.c + in particular and the way it sets up information relied on by + INCLUDE) requires that we read this now, and store the + "real-filename" info in master_input_filename. Ask the lexer + to try doing this. */ + ffelex_hash_kludge (finput); +} - /* Fill in arg stuff. */ +int +mark_addressable (exp) + tree exp; +{ + register tree x = exp; + while (1) + switch (TREE_CODE (x)) + { + case ADDR_EXPR: + case COMPONENT_REF: + case ARRAY_REF: + x = TREE_OPERAND (x, 0); + break; - DECL_ARG_TYPE (parm) = TREE_TYPE (parm); - DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm); - TREE_READONLY (parm) = 1; /* All implementation args are read-only. */ + case CONSTRUCTOR: + TREE_ADDRESSABLE (x) = 1; + return 1; - parm = pushdecl (parm); + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) + && DECL_NONLOCAL (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register variable requested" == NULL); + } + else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register var requested" == NULL); + } + put_var_into_stack (x); - immediate_size_expand = old_immediate_size_expand; + /* drops in */ + case FUNCTION_DECL: + TREE_ADDRESSABLE (x) = 1; +#if 0 /* poplevel deals with this now. */ + if (DECL_CONTEXT (x) == 0) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; +#endif - finish_decl (parm, NULL_TREE, FALSE); + default: + return 1; + } } -/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */ +/* If DECL has a cleanup, build and return that cleanup here. + This is a callback called by expand_expr. */ -static tree -pushdecl_top_level (x) - tree x; +tree +maybe_build_cleanup (decl) + tree decl UNUSED; { - register tree t; - register struct binding_level *b = current_binding_level; - register tree f = current_function_decl; - - current_binding_level = global_binding_level; - current_function_decl = NULL_TREE; - t = pushdecl (x); - current_binding_level = b; - current_function_decl = f; - return t; + /* There are no cleanups in Fortran. */ + return NULL_TREE; } -/* Store the list of declarations of the current level. - This is done for the parameter declarations of a function being defined, - after they are modified in the light of any missing parameters. */ +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. -static tree -storedecls (decls) - tree decls; -{ - return current_binding_level->names = decls; -} + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. -/* Store the parameter declarations into the current function declaration. - This is called after parsing the parameter declarations, before - digesting the body of the function. + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. - For an old-style definition, modify the function's type - to specify at least the number of arguments. */ + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ -static void -store_parm_decls (int is_main_program UNUSED) +tree +poplevel (keep, reverse, functionbody) + int keep; + int reverse; + int functionbody; { - register tree fndecl = current_function_decl; + register tree link; + /* The chain of decls was accumulated in reverse order. + Put it into forward order, just for cleanliness. */ + tree decls; + tree subblocks = current_binding_level->blocks; + tree block = 0; + tree decl; + int block_previously_created; - if (fndecl == error_mark_node) - return; + /* Get the decls in the order they were written. + Usually current_binding_level->names is in reverse order. + But parameter decls were previously put in forward order. */ - /* This is a chain of PARM_DECLs from old-style parm declarations. */ - DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ())); + if (reverse) + current_binding_level->names + = decls = nreverse (current_binding_level->names); + else + decls = current_binding_level->names; - /* Initialize the RTL code for the function. */ + /* Output any nested inline functions within this block + if they weren't already output. */ - init_function_start (fndecl, input_filename, lineno); + for (decl = decls; decl; decl = TREE_CHAIN (decl)) + if (TREE_CODE (decl) == FUNCTION_DECL + && ! TREE_ASM_WRITTEN (decl) + && DECL_INITIAL (decl) != 0 + && TREE_ADDRESSABLE (decl)) + { + /* If this decl was copied from a file-scope decl + on account of a block-scope extern decl, + propagate TREE_ADDRESSABLE to the file-scope decl. + + DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is + true, since then the decl goes through save_for_inline_copying. */ + if (DECL_ABSTRACT_ORIGIN (decl) != 0 + && DECL_ABSTRACT_ORIGIN (decl) != decl) + TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; + else if (DECL_SAVED_INSNS (decl) != 0) + { + push_function_context (); + output_inline_function (decl); + pop_function_context (); + } + } - /* Set up parameters and prepare for return, for the function. */ + /* If there were any declarations or structure tags in that level, + or if this level is a function body, + create a BLOCK to record them for the life of this function. */ - expand_function_start (fndecl, 0); -} + block = 0; + block_previously_created = (current_binding_level->this_block != 0); + if (block_previously_created) + block = current_binding_level->this_block; + else if (keep || functionbody) + block = make_node (BLOCK); + if (block != 0) + { + BLOCK_VARS (block) = decls; + BLOCK_SUBBLOCKS (block) = subblocks; + remember_end_note (block); + } -static tree -start_decl (tree decl, bool is_top_level) -{ - register tree tem; - bool at_top_level = (current_binding_level == global_binding_level); - bool top_level = is_top_level || at_top_level; + /* In each subblock, record that this is its superior. */ - /* Caller should pass TRUE for is_top_level only if we wouldn't be at top - level anyway. */ - assert (!is_top_level || !at_top_level); + for (link = subblocks; link; link = TREE_CHAIN (link)) + BLOCK_SUPERCONTEXT (link) = block; - /* The corresponding pop_obstacks is in finish_decl. */ - push_obstacks_nochange (); + /* Clear out the meanings of the local variables of this level. */ - if (DECL_INITIAL (decl) != NULL_TREE) + for (link = decls; link; link = TREE_CHAIN (link)) { - assert (DECL_INITIAL (decl) == error_mark_node); - assert (!DECL_EXTERNAL (decl)); + if (DECL_NAME (link) != 0) + { + /* If the ident. was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (link)) + { + if (TREE_USED (link)) + TREE_USED (DECL_NAME (link)) = 1; + if (TREE_ADDRESSABLE (link)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1; + } + IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0; + } } - else if (top_level) - assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1); - - /* For Fortran, we by default put things in .common when possible. */ - DECL_COMMON (decl) = 1; - /* Add this decl to the current binding level. TEM may equal DECL or it may - be a previous decl of the same name. */ - if (is_top_level) - tem = pushdecl_top_level (decl); - else - tem = pushdecl (decl); + /* If the level being exited is the top level of a function, + check over all the labels, and clear out the current + (function local) meanings of their names. */ - /* For a local variable, define the RTL now. */ - if (!top_level - /* But not if this is a duplicate decl and we preserved the rtl from the - previous one (which may or may not happen). */ - && DECL_RTL (tem) == 0) + if (functionbody) { - if (TYPE_SIZE (TREE_TYPE (tem)) != 0) - expand_decl (tem); - else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE - && DECL_INITIAL (tem) != 0) - expand_decl (tem); + /* If this is the top level block of a function, + the vars are the function's parameters. + Don't leave them in the BLOCK because they are + found in the FUNCTION_DECL instead. */ + + BLOCK_VARS (block) = 0; } - if (DECL_INITIAL (tem) != NULL_TREE) + /* Pop the current level, and free the structure for reuse. */ + + { + register struct binding_level *level = current_binding_level; + current_binding_level = current_binding_level->level_chain; + + level->level_chain = free_binding_level; + free_binding_level = level; + } + + /* Dispose of the block that we just made inside some higher level. */ + if (functionbody + && current_function_decl != error_mark_node) + DECL_INITIAL (current_function_decl) = block; + else if (block) { - /* When parsing and digesting the initializer, use temporary storage. - Do this even if we will ignore the value. */ - if (at_top_level) - temporary_allocation (); + if (!block_previously_created) + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); } + /* If we did not make a block for the level just exited, + any blocks made for inner levels + (since they cannot be recorded as subblocks in that level) + must be carried forward so they will later become subblocks + of something else. */ + else if (subblocks) + current_binding_level->blocks + = chainon (current_binding_level->blocks, subblocks); - return tem; + if (block) + TREE_USED (block) = 1; + return block; } -/* Create the FUNCTION_DECL for a function definition. - DECLSPECS and DECLARATOR are the parts of the declaration; - they describe the function's name and the type it returns, - but twisted together in a fashion that parallels the syntax of C. - - This function creates a binding context for the function body - as well as setting up the FUNCTION_DECL in current_function_decl. +void +print_lang_decl (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; +{ +} - Returns 1 on success. If the DECLARATOR is not suitable for a function - (it defines a datum instead), we return 0, which tells - yyparse to report a parse error. +void +print_lang_identifier (file, node, indent) + FILE *file; + tree node; + int indent; +{ + print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4); + print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); +} - NESTED is nonzero for a function nested within another function. */ +void +print_lang_statistics () +{ +} -static void -start_function (tree name, tree type, int nested, int public) +void +print_lang_type (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; { - tree decl1; - tree restype; - int old_immediate_size_expand = immediate_size_expand; +} - named_labels = 0; - shadowed_labels = 0; +/* Record a decl-node X as belonging to the current lexical scope. + Check for errors (such as an incompatible declaration for the same + name already seen in the same scope). - /* Don't expand any sizes in the return type of the function. */ - immediate_size_expand = 0; + Returns either X or an old decl for the same name. + If an old decl is returned, it may have been smashed + to agree with what X says. */ - if (nested) - { - assert (!public); - assert (current_function_decl != NULL_TREE); - assert (DECL_CONTEXT (current_function_decl) == NULL_TREE); - } - else - { - assert (current_function_decl == NULL_TREE); - } +tree +pushdecl (x) + tree x; +{ + register tree t; + register tree name = DECL_NAME (x); + register struct binding_level *b = current_binding_level; - if (TREE_CODE (type) == ERROR_MARK) - decl1 = current_function_decl = error_mark_node; + if ((TREE_CODE (x) == FUNCTION_DECL) + && (DECL_INITIAL (x) == 0) + && DECL_EXTERNAL (x)) + DECL_CONTEXT (x) = NULL_TREE; else + DECL_CONTEXT (x) = current_function_decl; + + if (name) { - decl1 = build_decl (FUNCTION_DECL, - name, - type); - TREE_PUBLIC (decl1) = public ? 1 : 0; - if (nested) - DECL_INLINE (decl1) = 1; - TREE_STATIC (decl1) = 1; - DECL_EXTERNAL (decl1) = 0; + if (IDENTIFIER_INVENTED (name)) + { +#if BUILT_FOR_270 + DECL_ARTIFICIAL (x) = 1; +#endif + DECL_IN_SYSTEM_HEADER (x) = 1; + } - announce_function (decl1); + t = lookup_name_current_level (name); - /* Make the init_value nonzero so pushdecl knows this is not tentative. - error_mark_node is replaced below (in poplevel) with the BLOCK. */ - DECL_INITIAL (decl1) = error_mark_node; + assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE)); - /* Record the decl so that the function name is defined. If we already have - a decl for this name, and it is a FUNCTION_DECL, use the old decl. */ + /* Don't push non-parms onto list for parms until we understand + why we're doing this and whether it works. */ - current_function_decl = pushdecl (decl1); - } + assert ((b == global_binding_level) + || !ffecom_transform_only_dummies_ + || TREE_CODE (x) == PARM_DECL); - if (!nested) - ffecom_outer_function_decl_ = current_function_decl; + if ((t != NULL_TREE) && duplicate_decls (x, t)) + return t; - pushlevel (0); + /* If we are processing a typedef statement, generate a whole new + ..._TYPE node (which will be just an variant of the existing + ..._TYPE node with identical properties) and then install the + TYPE_DECL node generated to represent the typedef name as the + TYPE_NAME of this brand new (duplicate) ..._TYPE node. - if (TREE_CODE (current_function_decl) != ERROR_MARK) - { - make_function_rtl (current_function_decl); + The whole point here is to end up with a situation where each and every + ..._TYPE node the compiler creates will be uniquely associated with + AT MOST one node representing a typedef name. This way, even though + the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL + (i.e. "typedef name") nodes very early on, later parts of the + compiler can always do the reverse translation and get back the + corresponding typedef name. For example, given: - restype = TREE_TYPE (TREE_TYPE (current_function_decl)); - DECL_RESULT (current_function_decl) - = build_decl (RESULT_DECL, NULL_TREE, restype); - } + typedef struct S MY_TYPE; MY_TYPE object; - if (!nested) - /* Allocate further tree nodes temporarily during compilation of this - function only. */ - temporary_allocation (); + Later parts of the compiler might only know that `object' was of type + `struct S' if it were not for code just below. With this code + however, later parts of the compiler see something like: - if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK)) - TREE_ADDRESSABLE (current_function_decl) = 1; + struct S' == struct S typedef struct S' MY_TYPE; struct S' object; - immediate_size_expand = old_immediate_size_expand; -} - -/* Here are the public functions the GNU back end needs. */ + And they can then deduce (from the node for type struct S') that the + original object declaration was: -tree -convert (type, expr) - tree type, expr; -{ - register tree e = expr; - register enum tree_code code = TREE_CODE (type); + MY_TYPE object; - if (type == TREE_TYPE (e) - || TREE_CODE (e) == ERROR_MARK) - return e; - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) - return fold (build1 (NOP_EXPR, type, e)); - if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK - || code == ERROR_MARK) - return error_mark_node; - if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) - { - assert ("void value not ignored as it ought to be" == NULL); - return error_mark_node; - } - if (code == VOID_TYPE) - return build1 (CONVERT_EXPR, type, e); - if ((code != RECORD_TYPE) - && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) - e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))), - e); - if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) - return fold (convert_to_integer (type, e)); - if (code == POINTER_TYPE) - return fold (convert_to_pointer (type, e)); - if (code == REAL_TYPE) - return fold (convert_to_real (type, e)); - if (code == COMPLEX_TYPE) - return fold (convert_to_complex (type, e)); - if (code == RECORD_TYPE) - return fold (ffecom_convert_to_complex_ (type, e)); + Being able to do this is important for proper support of protoize, and + also for generating precise symbolic debugging information which + takes full account of the programmer's (typedef) vocabulary. - assert ("conversion to non-scalar type requested" == NULL); - return error_mark_node; -} + Obviously, we don't want to generate a duplicate ..._TYPE node if the + TYPE_DECL node that we are now processing really represents a + standard built-in type. -/* integrate_decl_tree calls this function, but since we don't use the - DECL_LANG_SPECIFIC field, this is a no-op. */ + Since all standard types are effectively declared at line zero in the + source file, we can easily check to see if we are working on a + standard type by checking the current value of lineno. */ + + if (TREE_CODE (x) == TYPE_DECL) + { + if (DECL_SOURCE_LINE (x) == 0) + { + if (TYPE_NAME (TREE_TYPE (x)) == 0) + TYPE_NAME (TREE_TYPE (x)) = x; + } + else if (TREE_TYPE (x) != error_mark_node) + { + tree tt = TREE_TYPE (x); + + tt = build_type_copy (tt); + TYPE_NAME (tt) = x; + TREE_TYPE (x) = tt; + } + } -void -copy_lang_decl (node) - tree node UNUSED; -{ -} + /* This name is new in its binding level. Install the new declaration + and return it. */ + if (b == global_binding_level) + IDENTIFIER_GLOBAL_VALUE (name) = x; + else + IDENTIFIER_LOCAL_VALUE (name) = x; + } -/* Return the list of declarations of the current level. - Note that this list is in reverse order unless/until - you nreverse it; and when you do nreverse it, you must - store the result back using `storedecls' or you will lose. */ + /* Put decls on list in reverse order. We will reverse them later if + necessary. */ + TREE_CHAIN (x) = b->names; + b->names = x; -tree -getdecls () -{ - return current_binding_level->names; + return x; } -/* Nonzero if we are currently in the global binding level. */ +/* Nonzero if the current level needs to have a BLOCK made. */ -int -global_bindings_p () +static int +kept_level_p () { - return current_binding_level == global_binding_level; + tree decl; + + for (decl = current_binding_level->names; + decl; + decl = TREE_CHAIN (decl)) + { + if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL + || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl))) + /* Currently, there aren't supposed to be non-artificial names + at other than the top block for a function -- they're + believed to always be temps. But it's wise to check anyway. */ + return 1; + } + return 0; } -/* Insert BLOCK at the end of the list of subblocks of the - current binding level. This is used when a BIND_EXPR is expanded, - to handle the BLOCK node inside the BIND_EXPR. */ +/* Enter a new binding level. + If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, + not for that of tags. */ void -incomplete_type_error (value, type) - tree value UNUSED; - tree type; +pushlevel (tag_transparent) + int tag_transparent; { - if (TREE_CODE (type) == ERROR_MARK) - return; + register struct binding_level *newlevel = NULL_BINDING_LEVEL; - assert ("incomplete type?!?" == NULL); -} + assert (! tag_transparent); -void -init_decl_processing () -{ - malloc_init (); - ffe_init_0 (); -} + if (current_binding_level == global_binding_level) + { + named_labels = 0; + } -char * -init_parse (filename) - char *filename; -{ -#if BUILT_FOR_270 - extern void (*print_error_function) (char *); -#endif + /* Reuse or create a struct for this binding level. */ - /* Open input file. */ - if (filename == 0 || !strcmp (filename, "-")) + if (free_binding_level) { - finput = stdin; - filename = "stdin"; + newlevel = free_binding_level; + free_binding_level = free_binding_level->level_chain; } else - finput = fopen (filename, "r"); - if (finput == 0) - pfatal_with_name (filename); - -#ifdef IO_BUFFER_SIZE - setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE); -#endif + { + newlevel = make_binding_level (); + } - /* Make identifier nodes long enough for the language-specific slots. */ - set_identifier_size (sizeof (struct lang_identifier)); - decl_printable_name = lang_printable_name; -#if BUILT_FOR_270 - print_error_function = lang_print_error_function; -#endif + /* Add this level to the front of the chain (stack) of levels that + are active. */ - return filename; + *newlevel = clear_binding_level; + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; } -void -finish_parse () -{ - fclose (finput); -} +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ void -insert_block (block) - tree block; +set_block (block) + register tree block; { - TREE_USED (block) = 1; - current_binding_level->blocks - = chainon (current_binding_level->blocks, block); + current_binding_level->this_block = block; } -int -lang_decode_option (argc, argv) - int argc; - char **argv; -{ - return ffe_decode_option (argc, argv); -} +/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */ -/* used by print-tree.c */ +/* Can't 'yydebug' a front end not generated by yacc/bison! */ void -lang_print_xnode (file, node, indent) - FILE *file UNUSED; - tree node UNUSED; - int indent UNUSED; +set_yydebug (value) + int value; { + if (value) + fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n"); } -void -lang_finish () +tree +signed_or_unsigned_type (unsignedp, type) + int unsignedp; + tree type; { - ffe_terminate_0 (); - - if (ffe_is_ffedebug ()) - malloc_pool_display (malloc_pool_image ()); -} + tree type2; -char * -lang_identify () -{ - return "f77"; -} + if (! INTEGRAL_TYPE_P (type)) + return type; + if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); -void -lang_init_options () -{ - /* Set default options for Fortran. */ - flag_move_all_movables = 1; - flag_reduce_all_givs = 1; - flag_argument_noalias = 2; -} + type2 = type_for_size (TYPE_PRECISION (type), unsignedp); + if (type2 == NULL_TREE) + return type; -void -lang_init () -{ - /* If the file is output from cpp, it should contain a first line - `# 1 "real-filename"', and the current design of gcc (toplev.c - in particular and the way it sets up information relied on by - INCLUDE) requires that we read this now, and store the - "real-filename" info in master_input_filename. Ask the lexer - to try doing this. */ - ffelex_hash_kludge (finput); + return type2; } -int -mark_addressable (exp) - tree exp; +tree +signed_type (type) + tree type; { - register tree x = exp; - while (1) - switch (TREE_CODE (x)) - { - case ADDR_EXPR: - case COMPONENT_REF: - case ARRAY_REF: - x = TREE_OPERAND (x, 0); - break; + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; - case CONSTRUCTOR: - TREE_ADDRESSABLE (x) = 1; - return 1; + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; +#endif - case VAR_DECL: - case CONST_DECL: - case PARM_DECL: - case RESULT_DECL: - if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) - && DECL_NONLOCAL (x)) - { - if (TREE_PUBLIC (x)) - { - assert ("address of global register var requested" == NULL); - return 0; - } - assert ("address of register variable requested" == NULL); - } - else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) - { - if (TREE_PUBLIC (x)) - { - assert ("address of global register var requested" == NULL); - return 0; - } - assert ("address of register var requested" == NULL); - } - put_var_into_stack (x); + type2 = type_for_size (TYPE_PRECISION (type1), 0); + if (type2 != NULL_TREE) + return type2; - /* drops in */ - case FUNCTION_DECL: - TREE_ADDRESSABLE (x) = 1; -#if 0 /* poplevel deals with this now. */ - if (DECL_CONTEXT (x) == 0) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; -#endif + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; - default: - return 1; - } + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + } + + return type; } -/* If DECL has a cleanup, build and return that cleanup here. - This is a callback called by expand_expr. */ +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or validate its data type for an `if' or `while' statement or ?..: exp. + + This preparation consists of taking the ordinary + representation of an expression expr and producing a valid tree + boolean expression describing whether expr is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be `integer_type_node'. */ tree -maybe_build_cleanup (decl) - tree decl UNUSED; +truthvalue_conversion (expr) + tree expr; { - /* There are no cleanups in Fortran. */ - return NULL_TREE; -} + if (TREE_CODE (expr) == ERROR_MARK) + return expr; -/* Exit a binding level. - Pop the level off, and restore the state of the identifier-decl mappings - that were in effect when this level was entered. +#if 0 /* This appears to be wrong for C++. */ + /* These really should return error_mark_node after 2.4 is stable. + But not all callers handle ERROR_MARK properly. */ + switch (TREE_CODE (TREE_TYPE (expr))) + { + case RECORD_TYPE: + error ("struct type value used where scalar is required"); + return integer_zero_node; - If KEEP is nonzero, this level had explicit declarations, so - and create a "block" (a BLOCK node) for the level - to record its declarations and subblocks for symbol table output. + case UNION_TYPE: + error ("union type value used where scalar is required"); + return integer_zero_node; - If FUNCTIONBODY is nonzero, this level is the body of a function, - so create a block as if KEEP were set and also clear out all - label names. + case ARRAY_TYPE: + error ("array type value used where scalar is required"); + return integer_zero_node; - If REVERSE is nonzero, reverse the order of decls before putting - them into the BLOCK. */ + default: + break; + } +#endif /* 0 */ -tree -poplevel (keep, reverse, functionbody) - int keep; - int reverse; - int functionbody; -{ - register tree link; - /* The chain of decls was accumulated in reverse order. Put it into forward - order, just for cleanliness. */ - tree decls; - tree subblocks = current_binding_level->blocks; - tree block = 0; - tree decl; - int block_previously_created; + switch (TREE_CODE (expr)) + { + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + case COMPONENT_REF: + /* A one-bit unsigned bit-field is already acceptable. */ + if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) + && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) + return expr; + break; +#endif + + case EQ_EXPR: + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + if (integer_zerop (TREE_OPERAND (expr, 1))) + return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0); +#endif + case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + TREE_TYPE (expr) = integer_type_node; + return expr; - /* Get the decls in the order they were written. Usually - current_binding_level->names is in reverse order. But parameter decls - were previously put in forward order. */ + case ERROR_MARK: + return expr; - if (reverse) - current_binding_level->names - = decls = nreverse (current_binding_level->names); - else - decls = current_binding_level->names; + case INTEGER_CST: + return integer_zerop (expr) ? integer_zero_node : integer_one_node; - /* Output any nested inline functions within this block if they weren't - already output. */ + case REAL_CST: + return real_zerop (expr) ? integer_zero_node : integer_one_node; - for (decl = decls; decl; decl = TREE_CHAIN (decl)) - if (TREE_CODE (decl) == FUNCTION_DECL - && !TREE_ASM_WRITTEN (decl) - && DECL_INITIAL (decl) != 0 - && TREE_ADDRESSABLE (decl)) - { - /* If this decl was copied from a file-scope decl on account of a - block-scope extern decl, propagate TREE_ADDRESSABLE to the - file-scope decl. */ - if (DECL_ABSTRACT_ORIGIN (decl) != 0) - TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; - else - { - push_function_context (); - output_inline_function (decl); - pop_function_context (); - } - } + case ADDR_EXPR: + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) + return build (COMPOUND_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), integer_one_node); + else + return integer_one_node; - /* If there were any declarations or structure tags in that level, or if - this level is a function body, create a BLOCK to record them for the - life of this function. */ + case COMPLEX_EXPR: + return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (TREE_OPERAND (expr, 0)), + truthvalue_conversion (TREE_OPERAND (expr, 1))); - block = 0; - block_previously_created = (current_binding_level->this_block != 0); - if (block_previously_created) - block = current_binding_level->this_block; - else if (keep || functionbody) - block = make_node (BLOCK); - if (block != 0) - { - BLOCK_VARS (block) = decls; - BLOCK_SUBBLOCKS (block) = subblocks; - remember_end_note (block); - } + case NEGATE_EXPR: + case ABS_EXPR: + case FLOAT_EXPR: + case FFS_EXPR: + /* These don't change whether an object is non-zero or zero. */ + return truthvalue_conversion (TREE_OPERAND (expr, 0)); - /* In each subblock, record that this is its superior. */ + case LROTATE_EXPR: + case RROTATE_EXPR: + /* These don't change whether an object is zero or non-zero, but + we can't ignore them if their second arg has side-effects. */ + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) + return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1), + truthvalue_conversion (TREE_OPERAND (expr, 0))); + else + return truthvalue_conversion (TREE_OPERAND (expr, 0)); - for (link = subblocks; link; link = TREE_CHAIN (link)) - BLOCK_SUPERCONTEXT (link) = block; + case COND_EXPR: + /* Distribute the conversion into the arms of a COND_EXPR. */ + return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0), + truthvalue_conversion (TREE_OPERAND (expr, 1)), + truthvalue_conversion (TREE_OPERAND (expr, 2)))); - /* Clear out the meanings of the local variables of this level. */ + case CONVERT_EXPR: + /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, + since that affects how `default_conversion' will behave. */ + if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE + || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) + break; + /* fall through... */ + case NOP_EXPR: + /* If this is widening the argument, we can ignore it. */ + if (TYPE_PRECISION (TREE_TYPE (expr)) + >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + break; - for (link = decls; link; link = TREE_CHAIN (link)) - { - if (DECL_NAME (link) != 0) - { - /* If the ident. was used or addressed via a local extern decl, - don't forget that fact. */ - if (DECL_EXTERNAL (link)) - { - if (TREE_USED (link)) - TREE_USED (DECL_NAME (link)) = 1; - if (TREE_ADDRESSABLE (link)) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1; - } - IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0; - } + case MINUS_EXPR: + /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize + this case. */ + if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT + && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE) + break; + /* fall through... */ + case BIT_XOR_EXPR: + /* This and MINUS_EXPR can be changed into a comparison of the + two objects. */ + if (TREE_TYPE (TREE_OPERAND (expr, 0)) + == TREE_TYPE (TREE_OPERAND (expr, 1))) + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + TREE_OPERAND (expr, 1)); + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + fold (build1 (NOP_EXPR, + TREE_TYPE (TREE_OPERAND (expr, 0)), + TREE_OPERAND (expr, 1)))); + + case BIT_AND_EXPR: + if (integer_onep (TREE_OPERAND (expr, 1))) + return expr; + break; + + case MODIFY_EXPR: +#if 0 /* No such thing in Fortran. */ + if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR) + warning ("suggest parentheses around assignment used as truth value"); +#endif + break; + + default: + break; } - /* If the level being exited is the top level of a function, check over all - the labels, and clear out the current (function local) meanings of their - names. */ + if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) + return (ffecom_2 + ((TREE_SIDE_EFFECTS (expr) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (ffecom_1 (REALPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)), + truthvalue_conversion (ffecom_1 (IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)))); + + return ffecom_2 (NE_EXPR, integer_type_node, + expr, + convert (TREE_TYPE (expr), integer_zero_node)); +} + +tree +type_for_mode (mode, unsignedp) + enum machine_mode mode; + int unsignedp; +{ + int i; + int j; + tree t; - if (functionbody) - { - /* If this is the top level block of a function, the vars are the - function's parameters. Don't leave them in the BLOCK because they - are found in the FUNCTION_DECL instead. */ + if (mode == TYPE_MODE (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; - BLOCK_VARS (block) = 0; - } + if (mode == TYPE_MODE (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; - /* Pop the current level, and free the structure for reuse. */ + if (mode == TYPE_MODE (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; - { - register struct binding_level *level = current_binding_level; - current_binding_level = current_binding_level->level_chain; + if (mode == TYPE_MODE (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; - level->level_chain = free_binding_level; - free_binding_level = level; - } + if (mode == TYPE_MODE (long_long_integer_type_node)) + return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; - /* Dispose of the block that we just made inside some higher level. */ - if (functionbody - && current_function_decl != error_mark_node) - DECL_INITIAL (current_function_decl) = block; - else if (block) - { - if (!block_previously_created) - current_binding_level->blocks - = chainon (current_binding_level->blocks, block); - } - /* If we did not make a block for the level just exited, any blocks made - for inner levels (since they cannot be recorded as subblocks in that - level) must be carried forward so they will later become subblocks of - something else. */ - else if (subblocks) - current_binding_level->blocks - = chainon (current_binding_level->blocks, subblocks); + if (mode == TYPE_MODE (float_type_node)) + return float_type_node; - /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this - binding contour so that they point to the appropriate construct, i.e. - either to the current FUNCTION_DECL node, or else to the BLOCK node we - just constructed. + if (mode == TYPE_MODE (double_type_node)) + return double_type_node; - Note that for tagged types whose scope is just the formal parameter list - for some function type specification, we can't properly set their - TYPE_CONTEXTs here, because we don't have a pointer to the appropriate - FUNCTION_TYPE node readily available to us. For those cases, the - TYPE_CONTEXTs of the relevant tagged type nodes get set in - `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which - will represent the "scope" for these "parameter list local" tagged - types. */ + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return build_pointer_type (char_type_node); - if (block) - TREE_USED (block) = 1; - return block; -} + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return build_pointer_type (integer_type_node); -void -print_lang_decl (file, node, indent) - FILE *file UNUSED; - tree node UNUSED; - int indent UNUSED; -{ -} + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if (((t = ffecom_tree_type[i][j]) != NULL_TREE) + && (mode == TYPE_MODE (t))) + { + if ((i == FFEINFO_basictypeINTEGER) && unsignedp) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j]; + else + return t; + } + } -void -print_lang_identifier (file, node, indent) - FILE *file; - tree node; - int indent; -{ - print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4); - print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); + return 0; } -void -print_lang_statistics () +tree +type_for_size (bits, unsignedp) + unsigned bits; + int unsignedp; { -} + ffeinfoKindtype kt; + tree type_node; -void -print_lang_type (file, node, indent) - FILE *file UNUSED; - tree node UNUSED; - int indent UNUSED; -{ -} + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; -/* Record a decl-node X as belonging to the current lexical scope. - Check for errors (such as an incompatible declaration for the same - name already seen in the same scope). + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; - Returns either X or an old decl for the same name. - If an old decl is returned, it may have been smashed - to agree with what X says. */ + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; -tree -pushdecl (x) - tree x; -{ - register tree t; - register tree name = DECL_NAME (x); - register struct binding_level *b = current_binding_level; + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if ((TREE_CODE (x) == FUNCTION_DECL) - && (DECL_INITIAL (x) == 0) - && DECL_EXTERNAL (x)) - DECL_CONTEXT (x) = NULL_TREE; - else - DECL_CONTEXT (x) = current_function_decl; + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); - if (name) + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) { - if (IDENTIFIER_INVENTED (name)) - { -#if BUILT_FOR_270 - DECL_ARTIFICIAL (x) = 1; -#endif - DECL_IN_SYSTEM_HEADER (x) = 1; - } - - t = lookup_name_current_level (name); - - assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE)); + type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; - /* Don't push non-parms onto list for parms until we understand - why we're doing this and whether it works. */ + if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node))) + return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt] + : type_node; + } - assert ((b == global_binding_level) - || !ffecom_transform_only_dummies_ - || TREE_CODE (x) == PARM_DECL); + return 0; +} - if ((t != NULL_TREE) && duplicate_decls (x, t)) - return t; +tree +unsigned_type (type) + tree type; +{ + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; - /* If we are processing a typedef statement, generate a whole new - ..._TYPE node (which will be just an variant of the existing - ..._TYPE node with identical properties) and then install the - TYPE_DECL node generated to represent the typedef name as the - TYPE_NAME of this brand new (duplicate) ..._TYPE node. + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; +#endif - The whole point here is to end up with a situation where each and every - ..._TYPE node the compiler creates will be uniquely associated with - AT MOST one node representing a typedef name. This way, even though - the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL - (i.e. "typedef name") nodes very early on, later parts of the - compiler can always do the reverse translation and get back the - corresponding typedef name. For example, given: + type2 = type_for_size (TYPE_PRECISION (type1), 1); + if (type2 != NULL_TREE) + return type2; - typedef struct S MY_TYPE; MY_TYPE object; + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; - Later parts of the compiler might only know that `object' was of type - `struct S' if it were not for code just below. With this code - however, later parts of the compiler see something like: + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + } - struct S' == struct S typedef struct S' MY_TYPE; struct S' object; + return type; +} - And they can then deduce (from the node for type struct S') that the - original object declaration was: +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#if FFECOM_GCC_INCLUDE - MY_TYPE object; +/* From gcc/cccp.c, the code to handle -I. */ - Being able to do this is important for proper support of protoize, and - also for generating precise symbolic debugging information which - takes full account of the programmer's (typedef) vocabulary. +/* Skip leading "./" from a directory name. + This may yield the empty string, which represents the current directory. */ - Obviously, we don't want to generate a duplicate ..._TYPE node if the - TYPE_DECL node that we are now processing really represents a - standard built-in type. +static const char * +skip_redundant_dir_prefix (const char *dir) +{ + while (dir[0] == '.' && dir[1] == '/') + for (dir += 2; *dir == '/'; dir++) + continue; + if (dir[0] == '.' && !dir[1]) + dir++; + return dir; +} - Since all standard types are effectively declared at line zero in the - source file, we can easily check to see if we are working on a - standard type by checking the current value of lineno. */ +/* The file_name_map structure holds a mapping of file names for a + particular directory. This mapping is read from the file named + FILE_NAME_MAP_FILE in that directory. Such a file can be used to + map filenames on a file system with severe filename restrictions, + such as DOS. The format of the file name map file is just a series + of lines with two tokens on each line. The first token is the name + to map, and the second token is the actual name to use. */ - if (TREE_CODE (x) == TYPE_DECL) - { - if (DECL_SOURCE_LINE (x) == 0) - { - if (TYPE_NAME (TREE_TYPE (x)) == 0) - TYPE_NAME (TREE_TYPE (x)) = x; - } - else if (TREE_TYPE (x) != error_mark_node) - { - tree tt = TREE_TYPE (x); +struct file_name_map +{ + struct file_name_map *map_next; + char *map_from; + char *map_to; +}; - tt = build_type_copy (tt); - TYPE_NAME (tt) = x; - TREE_TYPE (x) = tt; - } - } +#define FILE_NAME_MAP_FILE "header.gcc" - /* This name is new in its binding level. Install the new declaration - and return it. */ - if (b == global_binding_level) - IDENTIFIER_GLOBAL_VALUE (name) = x; - else - IDENTIFIER_LOCAL_VALUE (name) = x; - } +/* Current maximum length of directory names in the search path + for include files. (Altered as we get more of them.) */ - /* Put decls on list in reverse order. We will reverse them later if - necessary. */ - TREE_CHAIN (x) = b->names; - b->names = x; +static int max_include_len = 0; - return x; -} +struct file_name_list + { + struct file_name_list *next; + char *fname; + /* Mapping of file names for this directory. */ + struct file_name_map *name_map; + /* Non-zero if name_map is valid. */ + int got_name_map; + }; -/* Enter a new binding level. - If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, - not for that of tags. */ +static struct file_name_list *include = NULL; /* First dir to search */ +static struct file_name_list *last_include = NULL; /* Last in chain */ -void -pushlevel (tag_transparent) - int tag_transparent; -{ - register struct binding_level *newlevel = NULL_BINDING_LEVEL; +/* I/O buffer structure. + The `fname' field is nonzero for source files and #include files + and for the dummy text used for -D and -U. + It is zero for rescanning results of macro expansion + and for expanding macro arguments. */ +#define INPUT_STACK_MAX 400 +static struct file_buf { + char *fname; + /* Filename specified with #line command. */ + char *nominal_fname; + /* Record where in the search path this file was found. + For #include_next. */ + struct file_name_list *dir; + ffewhereLine line; + ffewhereColumn column; +} instack[INPUT_STACK_MAX]; - assert (!tag_transparent); +static int last_error_tick = 0; /* Incremented each time we print it. */ +static int input_file_stack_tick = 0; /* Incremented when status changes. */ - /* Reuse or create a struct for this binding level. */ +/* Current nesting level of input sources. + `instack[indepth]' is the level currently being read. */ +static int indepth = -1; - if (free_binding_level) - { - newlevel = free_binding_level; - free_binding_level = free_binding_level->level_chain; - } - else - { - newlevel = make_binding_level (); - } +typedef struct file_buf FILE_BUF; - /* Add this level to the front of the chain (stack) of levels that are - active. */ +typedef unsigned char U_CHAR; - *newlevel = clear_binding_level; - newlevel->level_chain = current_binding_level; - current_binding_level = newlevel; -} +/* table to tell if char can be part of a C identifier. */ +U_CHAR is_idchar[256]; +/* table to tell if char can be first char of a c identifier. */ +U_CHAR is_idstart[256]; +/* table to tell if c is horizontal space. */ +U_CHAR is_hor_space[256]; +/* table to tell if c is horizontal or vertical space. */ +static U_CHAR is_space[256]; -/* Set the BLOCK node for the innermost scope - (the one we are currently in). */ +#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0) +#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0) -void -set_block (block) - register tree block; -{ - current_binding_level->this_block = block; -} +/* Nonzero means -I- has been seen, + so don't look for #include "foo" the source-file directory. */ +static int ignore_srcdir; -/* ~~tree.h SHOULD declare this, because toplev.c references it. */ +#ifndef INCLUDE_LEN_FUDGE +#define INCLUDE_LEN_FUDGE 0 +#endif -/* Can't 'yydebug' a front end not generated by yacc/bison! */ +static void append_include_chain (struct file_name_list *first, + struct file_name_list *last); +static FILE *open_include_file (char *filename, + struct file_name_list *searchptr); +static void print_containing_files (ffebadSeverity sev); +static const char *skip_redundant_dir_prefix (const char *); +static char *read_filename_string (int ch, FILE *f); +static struct file_name_map *read_name_map (const char *dirname); -void -set_yydebug (value) - int value; -{ - if (value) - fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n"); -} +/* Append a chain of `struct file_name_list's + to the end of the main include chain. + FIRST is the beginning of the chain to append, and LAST is the end. */ -tree -signed_or_unsigned_type (unsignedp, type) - int unsignedp; - tree type; +static void +append_include_chain (first, last) + struct file_name_list *first, *last; { - tree type2; + struct file_name_list *dir; - if (! INTEGRAL_TYPE_P (type)) - return type; - if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; - if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); + if (!first || !last) + return; - type2 = type_for_size (TYPE_PRECISION (type), unsignedp); - if (type2 == NULL_TREE) - return type; + if (include == 0) + include = first; + else + last_include->next = first; - return type2; + for (dir = first; ; dir = dir->next) { + int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE; + if (len > max_include_len) + max_include_len = len; + if (dir == last) + break; + } + + last->next = NULL; + last_include = last; } -tree -signed_type (type) - tree type; +/* Try to open include file FILENAME. SEARCHPTR is the directory + being tried from the include file search path. This function maps + filenames on file systems based on information read by + read_name_map. */ + +static FILE * +open_include_file (filename, searchptr) + char *filename; + struct file_name_list *searchptr; { - tree type1 = TYPE_MAIN_VARIANT (type); - ffeinfoKindtype kt; - tree type2; + register struct file_name_map *map; + register char *from; + char *p, *dir; - if (type1 == unsigned_char_type_node || type1 == char_type_node) - return signed_char_type_node; - if (type1 == unsigned_type_node) - return integer_type_node; - if (type1 == short_unsigned_type_node) - return short_integer_type_node; - if (type1 == long_unsigned_type_node) - return long_integer_type_node; - if (type1 == long_long_unsigned_type_node) - return long_long_integer_type_node; -#if 0 /* gcc/c-* files only */ - if (type1 == unsigned_intDI_type_node) - return intDI_type_node; - if (type1 == unsigned_intSI_type_node) - return intSI_type_node; - if (type1 == unsigned_intHI_type_node) - return intHI_type_node; - if (type1 == unsigned_intQI_type_node) - return intQI_type_node; -#endif + if (searchptr && ! searchptr->got_name_map) + { + searchptr->name_map = read_name_map (searchptr->fname + ? searchptr->fname : "."); + searchptr->got_name_map = 1; + } - type2 = type_for_size (TYPE_PRECISION (type1), 0); - if (type2 != NULL_TREE) - return type2; + /* First check the mapping for the directory we are using. */ + if (searchptr && searchptr->name_map) + { + from = filename; + if (searchptr->fname) + from += strlen (searchptr->fname) + 1; + for (map = searchptr->name_map; map; map = map->map_next) + { + if (! strcmp (map->map_from, from)) + { + /* Found a match. */ + return fopen (map->map_to, "r"); + } + } + } - for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + /* Try to find a mapping file for the particular directory we are + looking in. Thus #include will look up sys/types.h + in /usr/include/header.gcc and look up types.h in + /usr/include/sys/header.gcc. */ + p = rindex (filename, '/'); +#ifdef DIR_SEPARATOR + if (! p) p = rindex (filename, DIR_SEPARATOR); + else { + char *tmp = rindex (filename, DIR_SEPARATOR); + if (tmp != NULL && tmp > p) p = tmp; + } +#endif + if (! p) + p = filename; + if (searchptr + && searchptr->fname + && strlen (searchptr->fname) == (size_t) (p - filename) + && ! strncmp (searchptr->fname, filename, (int) (p - filename))) + { + /* FILENAME is in SEARCHPTR, which we've already checked. */ + return fopen (filename, "r"); + } + + if (p == filename) + { + from = filename; + map = read_name_map ("."); + } + else { - type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; - - if (type1 == type2) - return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + dir = (char *) xmalloc (p - filename + 1); + memcpy (dir, filename, p - filename); + dir[p - filename] = '\0'; + from = p + 1; + map = read_name_map (dir); + free (dir); } + for (; map; map = map->map_next) + if (! strcmp (map->map_from, from)) + return fopen (map->map_to, "r"); - return type; + return fopen (filename, "r"); } -/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, - or validate its data type for an `if' or `while' statement or ?..: exp. +/* Print the file names and line numbers of the #include + commands which led to the current file. */ - This preparation consists of taking the ordinary - representation of an expression expr and producing a valid tree - boolean expression describing whether expr is nonzero. We could - simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), - but we optimize comparisons, &&, ||, and !. +static void +print_containing_files (ffebadSeverity sev) +{ + FILE_BUF *ip = NULL; + int i; + int first = 1; + const char *str1; + const char *str2; - The resulting type should always be `integer_type_node'. */ + /* If stack of files hasn't changed since we last printed + this info, don't repeat it. */ + if (last_error_tick == input_file_stack_tick) + return; -tree -truthvalue_conversion (expr) - tree expr; -{ - if (TREE_CODE (expr) == ERROR_MARK) - return expr; + for (i = indepth; i >= 0; i--) + if (instack[i].fname != NULL) { + ip = &instack[i]; + break; + } -#if 0 /* This appears to be wrong for C++. */ - /* These really should return error_mark_node after 2.4 is stable. - But not all callers handle ERROR_MARK properly. */ - switch (TREE_CODE (TREE_TYPE (expr))) - { - case RECORD_TYPE: - error ("struct type value used where scalar is required"); - return integer_zero_node; + /* Give up if we don't find a source file. */ + if (ip == NULL) + return; - case UNION_TYPE: - error ("union type value used where scalar is required"); - return integer_zero_node; + /* Find the other, outer source files. */ + for (i--; i >= 0; i--) + if (instack[i].fname != NULL) + { + ip = &instack[i]; + if (first) + { + first = 0; + str1 = "In file included"; + } + else + { + str1 = "... ..."; + } - case ARRAY_TYPE: - error ("array type value used where scalar is required"); - return integer_zero_node; + if (i == 1) + str2 = ":"; + else + str2 = ""; - default: - break; - } -#endif /* 0 */ + ffebad_start_msg ("%A from %B at %0%C", sev); + ffebad_here (0, ip->line, ip->column); + ffebad_string (str1); + ffebad_string (ip->nominal_fname); + ffebad_string (str2); + ffebad_finish (); + } - switch (TREE_CODE (expr)) - { - /* It is simpler and generates better code to have only TRUTH_*_EXPR - or comparison expressions as truth values at this level. */ -#if 0 - case COMPONENT_REF: - /* A one-bit unsigned bit-field is already acceptable. */ - if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) - && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) - return expr; - break; -#endif + /* Record we have printed the status as of this time. */ + last_error_tick = input_file_stack_tick; +} - case EQ_EXPR: - /* It is simpler and generates better code to have only TRUTH_*_EXPR - or comparison expressions as truth values at this level. */ -#if 0 - if (integer_zerop (TREE_OPERAND (expr, 1))) - return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0); -#endif - case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: - case TRUTH_ANDIF_EXPR: - case TRUTH_ORIF_EXPR: - case TRUTH_AND_EXPR: - case TRUTH_OR_EXPR: - case TRUTH_XOR_EXPR: - TREE_TYPE (expr) = integer_type_node; - return expr; +/* Read a space delimited string of unlimited length from a stdio + file. */ - case ERROR_MARK: - return expr; +static char * +read_filename_string (ch, f) + int ch; + FILE *f; +{ + char *alloc, *set; + int len; - case INTEGER_CST: - return integer_zerop (expr) ? integer_zero_node : integer_one_node; + len = 20; + set = alloc = xmalloc (len + 1); + if (! is_space[ch]) + { + *set++ = ch; + while ((ch = getc (f)) != EOF && ! is_space[ch]) + { + if (set - alloc == len) + { + len *= 2; + alloc = xrealloc (alloc, len + 1); + set = alloc + len / 2; + } + *set++ = ch; + } + } + *set = '\0'; + ungetc (ch, f); + return alloc; +} - case REAL_CST: - return real_zerop (expr) ? integer_zero_node : integer_one_node; +/* Read the file name map file for DIRNAME. */ - case ADDR_EXPR: - if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) - return build (COMPOUND_EXPR, integer_type_node, - TREE_OPERAND (expr, 0), integer_one_node); - else - return integer_one_node; +static struct file_name_map * +read_name_map (dirname) + const char *dirname; +{ + /* This structure holds a linked list of file name maps, one per + directory. */ + struct file_name_map_list + { + struct file_name_map_list *map_list_next; + char *map_list_name; + struct file_name_map *map_list_map; + }; + static struct file_name_map_list *map_list; + register struct file_name_map_list *map_list_ptr; + char *name; + FILE *f; + size_t dirlen; + int separator_needed; - case COMPLEX_EXPR: - return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) - ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), - integer_type_node, - truthvalue_conversion (TREE_OPERAND (expr, 0)), - truthvalue_conversion (TREE_OPERAND (expr, 1))); + dirname = skip_redundant_dir_prefix (dirname); - case NEGATE_EXPR: - case ABS_EXPR: - case FLOAT_EXPR: - case FFS_EXPR: - /* These don't change whether an object is non-zero or zero. */ - return truthvalue_conversion (TREE_OPERAND (expr, 0)); + for (map_list_ptr = map_list; map_list_ptr; + map_list_ptr = map_list_ptr->map_list_next) + if (! strcmp (map_list_ptr->map_list_name, dirname)) + return map_list_ptr->map_list_map; - case LROTATE_EXPR: - case RROTATE_EXPR: - /* These don't change whether an object is zero or non-zero, but - we can't ignore them if their second arg has side-effects. */ - if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) - return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1), - truthvalue_conversion (TREE_OPERAND (expr, 0))); - else - return truthvalue_conversion (TREE_OPERAND (expr, 0)); + map_list_ptr = ((struct file_name_map_list *) + xmalloc (sizeof (struct file_name_map_list))); + map_list_ptr->map_list_name = xstrdup (dirname); + map_list_ptr->map_list_map = NULL; - case COND_EXPR: - /* Distribute the conversion into the arms of a COND_EXPR. */ - return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0), - truthvalue_conversion (TREE_OPERAND (expr, 1)), - truthvalue_conversion (TREE_OPERAND (expr, 2)))); + dirlen = strlen (dirname); + separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; + name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2); + strcpy (name, dirname); + name[dirlen] = '/'; + strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE); + f = fopen (name, "r"); + free (name); + if (!f) + map_list_ptr->map_list_map = NULL; + else + { + int ch; - case CONVERT_EXPR: - /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, - since that affects how `default_conversion' will behave. */ - if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE - || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) - break; - /* fall through... */ - case NOP_EXPR: - /* If this is widening the argument, we can ignore it. */ - if (TYPE_PRECISION (TREE_TYPE (expr)) - >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) - return truthvalue_conversion (TREE_OPERAND (expr, 0)); - break; + while ((ch = getc (f)) != EOF) + { + char *from, *to; + struct file_name_map *ptr; + + if (is_space[ch]) + continue; + from = read_filename_string (ch, f); + while ((ch = getc (f)) != EOF && is_hor_space[ch]) + ; + to = read_filename_string (ch, f); - case MINUS_EXPR: - /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize - this case. */ - if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT - && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE) - break; - /* fall through... */ - case BIT_XOR_EXPR: - /* This and MINUS_EXPR can be changed into a comparison of the - two objects. */ - if (TREE_TYPE (TREE_OPERAND (expr, 0)) - == TREE_TYPE (TREE_OPERAND (expr, 1))) - return ffecom_2 (NE_EXPR, integer_type_node, - TREE_OPERAND (expr, 0), - TREE_OPERAND (expr, 1)); - return ffecom_2 (NE_EXPR, integer_type_node, - TREE_OPERAND (expr, 0), - fold (build1 (NOP_EXPR, - TREE_TYPE (TREE_OPERAND (expr, 0)), - TREE_OPERAND (expr, 1)))); + ptr = ((struct file_name_map *) + xmalloc (sizeof (struct file_name_map))); + ptr->map_from = from; - case BIT_AND_EXPR: - if (integer_onep (TREE_OPERAND (expr, 1))) - return expr; - break; + /* Make the real filename absolute. */ + if (*to == '/') + ptr->map_to = to; + else + { + ptr->map_to = xmalloc (dirlen + strlen (to) + 2); + strcpy (ptr->map_to, dirname); + ptr->map_to[dirlen] = '/'; + strcpy (ptr->map_to + dirlen + separator_needed, to); + free (to); + } - case MODIFY_EXPR: -#if 0 /* No such thing in Fortran. */ - if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR) - warning ("suggest parentheses around assignment used as truth value"); -#endif - break; + ptr->map_next = map_list_ptr->map_list_map; + map_list_ptr->map_list_map = ptr; - default: - break; + while ((ch = getc (f)) != '\n') + if (ch == EOF) + break; + } + fclose (f); } - if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) - return (ffecom_2 - ((TREE_SIDE_EFFECTS (expr) - ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), - integer_type_node, - truthvalue_conversion (ffecom_1 (REALPART_EXPR, - TREE_TYPE (TREE_TYPE (expr)), - expr)), - truthvalue_conversion (ffecom_1 (IMAGPART_EXPR, - TREE_TYPE (TREE_TYPE (expr)), - expr)))); + map_list_ptr->map_list_next = map_list; + map_list = map_list_ptr; - return ffecom_2 (NE_EXPR, integer_type_node, - expr, - convert (TREE_TYPE (expr), integer_zero_node)); + return map_list_ptr->map_list_map; } -tree -type_for_mode (mode, unsignedp) - enum machine_mode mode; - int unsignedp; +static void +ffecom_file_ (char *name) { - int i; - int j; - tree t; + FILE_BUF *fp; - if (mode == TYPE_MODE (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; + /* Do partial setup of input buffer for the sake of generating + early #line directives (when -g is in effect). */ - if (mode == TYPE_MODE (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; + fp = &instack[++indepth]; + memset ((char *) fp, 0, sizeof (FILE_BUF)); + if (name == NULL) + name = ""; + fp->nominal_fname = fp->fname = name; +} - if (mode == TYPE_MODE (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; +/* Initialize syntactic classifications of characters. */ - if (mode == TYPE_MODE (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; +static void +ffecom_initialize_char_syntax_ () +{ + register int i; - if (mode == TYPE_MODE (long_long_integer_type_node)) - return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; + /* + * Set up is_idchar and is_idstart tables. These should be + * faster than saying (is_alpha (c) || c == '_'), etc. + * Set up these things before calling any routines tthat + * refer to them. + */ + for (i = 'a'; i <= 'z'; i++) { + is_idchar[i - 'a' + 'A'] = 1; + is_idchar[i] = 1; + is_idstart[i - 'a' + 'A'] = 1; + is_idstart[i] = 1; + } + for (i = '0'; i <= '9'; i++) + is_idchar[i] = 1; + is_idchar['_'] = 1; + is_idstart['_'] = 1; - if (mode == TYPE_MODE (float_type_node)) - return float_type_node; + /* horizontal space table */ + is_hor_space[' '] = 1; + is_hor_space['\t'] = 1; + is_hor_space['\v'] = 1; + is_hor_space['\f'] = 1; + is_hor_space['\r'] = 1; - if (mode == TYPE_MODE (double_type_node)) - return double_type_node; + is_space[' '] = 1; + is_space['\t'] = 1; + is_space['\v'] = 1; + is_space['\f'] = 1; + is_space['\n'] = 1; + is_space['\r'] = 1; +} - if (mode == TYPE_MODE (build_pointer_type (char_type_node))) - return build_pointer_type (char_type_node); +static void +ffecom_close_include_ (FILE *f) +{ + fclose (f); - if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) - return build_pointer_type (integer_type_node); + indepth--; + input_file_stack_tick++; - for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) - for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) - { - if (((t = ffecom_tree_type[i][j]) != NULL_TREE) - && (mode == TYPE_MODE (t))) - { - if ((i == FFEINFO_basictypeINTEGER) && unsignedp) - return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j]; - else - return t; - } - } + ffewhere_line_kill (instack[indepth].line); + ffewhere_column_kill (instack[indepth].column); +} - return 0; +static int +ffecom_decode_include_option_ (char *spec) +{ + struct file_name_list *dirtmp; + + if (! ignore_srcdir && !strcmp (spec, "-")) + ignore_srcdir = 1; + else + { + dirtmp = (struct file_name_list *) + xmalloc (sizeof (struct file_name_list)); + dirtmp->next = 0; /* New one goes on the end */ + if (spec[0] != 0) + dirtmp->fname = spec; + else + fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'"); + dirtmp->got_name_map = 0; + append_include_chain (dirtmp, dirtmp); + } + return 1; } -tree -type_for_size (bits, unsignedp) - unsigned bits; - int unsignedp; +/* Open INCLUDEd file. */ + +static FILE * +ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) { - ffeinfoKindtype kt; - tree type_node; + char *fbeg = name; + size_t flen = strlen (fbeg); + struct file_name_list *search_start = include; /* Chain of dirs to search */ + struct file_name_list dsp[1]; /* First in chain, if #include "..." */ + struct file_name_list *searchptr = 0; + char *fname; /* Dynamically allocated fname buffer */ + FILE *f; + FILE_BUF *fp; - if (bits == TYPE_PRECISION (integer_type_node)) - return unsignedp ? unsigned_type_node : integer_type_node; + if (flen == 0) + return NULL; - if (bits == TYPE_PRECISION (signed_char_type_node)) - return unsignedp ? unsigned_char_type_node : signed_char_type_node; + dsp[0].fname = NULL; - if (bits == TYPE_PRECISION (short_integer_type_node)) - return unsignedp ? short_unsigned_type_node : short_integer_type_node; + /* If -I- was specified, don't search current dir, only spec'd ones. */ + if (!ignore_srcdir) + { + for (fp = &instack[indepth]; fp >= instack; fp--) + { + int n; + char *ep; + char *nam; - if (bits == TYPE_PRECISION (long_integer_type_node)) - return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if ((nam = fp->nominal_fname) != NULL) + { + /* Found a named file. Figure out dir of the file, + and put it in front of the search list. */ + dsp[0].next = search_start; + search_start = dsp; +#ifndef VMS + ep = rindex (nam, '/'); +#ifdef DIR_SEPARATOR + if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR); + else { + char *tmp = rindex (nam, DIR_SEPARATOR); + if (tmp != NULL && tmp > ep) ep = tmp; + } +#endif +#else /* VMS */ + ep = rindex (nam, ']'); + if (ep == NULL) ep = rindex (nam, '>'); + if (ep == NULL) ep = rindex (nam, ':'); + if (ep != NULL) ep++; +#endif /* VMS */ + if (ep != NULL) + { + n = ep - nam; + dsp[0].fname = (char *) xmalloc (n + 1); + strncpy (dsp[0].fname, nam, n); + dsp[0].fname[n] = '\0'; + if (n + INCLUDE_LEN_FUDGE > max_include_len) + max_include_len = n + INCLUDE_LEN_FUDGE; + } + else + dsp[0].fname = NULL; /* Current directory */ + dsp[0].got_name_map = 0; + break; + } + } + } - if (bits == TYPE_PRECISION (long_long_integer_type_node)) - return (unsignedp ? long_long_unsigned_type_node - : long_long_integer_type_node); + /* Allocate this permanently, because it gets stored in the definitions + of macros. */ + fname = xmalloc (max_include_len + flen + 4); + /* + 2 above for slash and terminating null. */ + /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED + for g77 yet). */ - for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) - { - type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + /* If specified file name is absolute, just open it. */ - if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node))) - return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt] - : type_node; + if (*fbeg == '/' +#ifdef DIR_SEPARATOR + || *fbeg == DIR_SEPARATOR +#endif + ) + { + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + f = open_include_file (fname, NULL_PTR); } + else + { + f = NULL; - return 0; -} + /* Search directory path, trying to open the file. + Copy each filename tried into FNAME. */ -tree -unsigned_type (type) - tree type; -{ - tree type1 = TYPE_MAIN_VARIANT (type); - ffeinfoKindtype kt; - tree type2; + for (searchptr = search_start; searchptr; searchptr = searchptr->next) + { + if (searchptr->fname) + { + /* The empty string in a search path is ignored. + This makes it possible to turn off entirely + a standard piece of the list. */ + if (searchptr->fname[0] == 0) + continue; + strcpy (fname, skip_redundant_dir_prefix (searchptr->fname)); + if (fname[0] && fname[strlen (fname) - 1] != '/') + strcat (fname, "/"); + fname[strlen (fname) + flen] = 0; + } + else + fname[0] = 0; - if (type1 == signed_char_type_node || type1 == char_type_node) - return unsigned_char_type_node; - if (type1 == integer_type_node) - return unsigned_type_node; - if (type1 == short_integer_type_node) - return short_unsigned_type_node; - if (type1 == long_integer_type_node) - return long_unsigned_type_node; - if (type1 == long_long_integer_type_node) - return long_long_unsigned_type_node; -#if 0 /* gcc/c-* files only */ - if (type1 == intDI_type_node) - return unsigned_intDI_type_node; - if (type1 == intSI_type_node) - return unsigned_intSI_type_node; - if (type1 == intHI_type_node) - return unsigned_intHI_type_node; - if (type1 == intQI_type_node) - return unsigned_intQI_type_node; + strncat (fname, fbeg, flen); +#ifdef VMS + /* Change this 1/2 Unix 1/2 VMS file specification into a + full VMS file specification */ + if (searchptr->fname && (searchptr->fname[0] != 0)) + { + /* Fix up the filename */ + hack_vms_include_specification (fname); + } + else + { + /* This is a normal VMS filespec, so use it unchanged. */ + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; +#if 0 /* Not for g77. */ + /* if it's '#include filename', add the missing .h */ + if (index (fname, '.') == NULL) + strcat (fname, ".h"); #endif + } +#endif /* VMS */ + f = open_include_file (fname, searchptr); +#ifdef EACCES + if (f == NULL && errno == EACCES) + { + print_containing_files (FFEBAD_severityWARNING); + ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable", + FFEBAD_severityWARNING); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + } +#endif + if (f != NULL) + break; + } + } - type2 = type_for_size (TYPE_PRECISION (type1), 1); - if (type2 != NULL_TREE) - return type2; - - for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + if (f == NULL) { - type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + /* A file that was not found. */ - if (type1 == type2) - return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE)); + ffebad_start (FFEBAD_OPEN_INCLUDE); + ffebad_here (0, l, c); + ffebad_string (fname); + ffebad_finish (); } - return type; -} - -#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ - -#if FFECOM_GCC_INCLUDE - -/* From gcc/cccp.c, the code to handle -I. */ - -/* Skip leading "./" from a directory name. - This may yield the empty string, which represents the current directory. */ + if (dsp[0].fname != NULL) + free (dsp[0].fname); -static const char * -skip_redundant_dir_prefix (const char *dir) -{ - while (dir[0] == '.' && dir[1] == '/') - for (dir += 2; *dir == '/'; dir++) - continue; - if (dir[0] == '.' && !dir[1]) - dir++; - return dir; -} + if (f == NULL) + return NULL; -/* The file_name_map structure holds a mapping of file names for a - particular directory. This mapping is read from the file named - FILE_NAME_MAP_FILE in that directory. Such a file can be used to - map filenames on a file system with severe filename restrictions, - such as DOS. The format of the file name map file is just a series - of lines with two tokens on each line. The first token is the name - to map, and the second token is the actual name to use. */ + if (indepth >= (INPUT_STACK_MAX - 1)) + { + print_containing_files (FFEBAD_severityFATAL); + ffebad_start_msg ("At %0, INCLUDE nesting too deep", + FFEBAD_severityFATAL); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + return NULL; + } -struct file_name_map -{ - struct file_name_map *map_next; - char *map_from; - char *map_to; -}; + instack[indepth].line = ffewhere_line_use (l); + instack[indepth].column = ffewhere_column_use (c); -#define FILE_NAME_MAP_FILE "header.gcc" + fp = &instack[indepth + 1]; + memset ((char *) fp, 0, sizeof (FILE_BUF)); + fp->nominal_fname = fp->fname = fname; + fp->dir = searchptr; -/* Current maximum length of directory names in the search path - for include files. (Altered as we get more of them.) */ + indepth++; + input_file_stack_tick++; -static int max_include_len = 0; + return f; +} +#endif /* FFECOM_GCC_INCLUDE */ -struct file_name_list - { - struct file_name_list *next; - char *fname; - /* Mapping of file names for this directory. */ - struct file_name_map *name_map; - /* Non-zero if name_map is valid. */ - int got_name_map; - }; +/**INDENT* (Do not reformat this comment even with -fca option.) + Data-gathering files: Given the source file listed below, compiled with + f2c I obtained the output file listed after that, and from the output + file I derived the above code. -static struct file_name_list *include = NULL; /* First dir to search */ -static struct file_name_list *last_include = NULL; /* Last in chain */ +-------- (begin input file to f2c) + implicit none + character*10 A1,A2 + complex C1,C2 + integer I1,I2 + real R1,R2 + double precision D1,D2 +C + call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) +c / + call fooI(I1/I2) + call fooR(R1/I1) + call fooD(D1/I1) + call fooC(C1/I1) + call fooR(R1/R2) + call fooD(R1/D1) + call fooD(D1/D2) + call fooD(D1/R1) + call fooC(C1/C2) + call fooC(C1/R1) + call fooZ(C1/D1) +c ** + call fooI(I1**I2) + call fooR(R1**I1) + call fooD(D1**I1) + call fooC(C1**I1) + call fooR(R1**R2) + call fooD(R1**D1) + call fooD(D1**D2) + call fooD(D1**R1) + call fooC(C1**C2) + call fooC(C1**R1) + call fooZ(C1**D1) +c FFEINTRIN_impABS + call fooR(ABS(R1)) +c FFEINTRIN_impACOS + call fooR(ACOS(R1)) +c FFEINTRIN_impAIMAG + call fooR(AIMAG(C1)) +c FFEINTRIN_impAINT + call fooR(AINT(R1)) +c FFEINTRIN_impALOG + call fooR(ALOG(R1)) +c FFEINTRIN_impALOG10 + call fooR(ALOG10(R1)) +c FFEINTRIN_impAMAX0 + call fooR(AMAX0(I1,I2)) +c FFEINTRIN_impAMAX1 + call fooR(AMAX1(R1,R2)) +c FFEINTRIN_impAMIN0 + call fooR(AMIN0(I1,I2)) +c FFEINTRIN_impAMIN1 + call fooR(AMIN1(R1,R2)) +c FFEINTRIN_impAMOD + call fooR(AMOD(R1,R2)) +c FFEINTRIN_impANINT + call fooR(ANINT(R1)) +c FFEINTRIN_impASIN + call fooR(ASIN(R1)) +c FFEINTRIN_impATAN + call fooR(ATAN(R1)) +c FFEINTRIN_impATAN2 + call fooR(ATAN2(R1,R2)) +c FFEINTRIN_impCABS + call fooR(CABS(C1)) +c FFEINTRIN_impCCOS + call fooC(CCOS(C1)) +c FFEINTRIN_impCEXP + call fooC(CEXP(C1)) +c FFEINTRIN_impCHAR + call fooA(CHAR(I1)) +c FFEINTRIN_impCLOG + call fooC(CLOG(C1)) +c FFEINTRIN_impCONJG + call fooC(CONJG(C1)) +c FFEINTRIN_impCOS + call fooR(COS(R1)) +c FFEINTRIN_impCOSH + call fooR(COSH(R1)) +c FFEINTRIN_impCSIN + call fooC(CSIN(C1)) +c FFEINTRIN_impCSQRT + call fooC(CSQRT(C1)) +c FFEINTRIN_impDABS + call fooD(DABS(D1)) +c FFEINTRIN_impDACOS + call fooD(DACOS(D1)) +c FFEINTRIN_impDASIN + call fooD(DASIN(D1)) +c FFEINTRIN_impDATAN + call fooD(DATAN(D1)) +c FFEINTRIN_impDATAN2 + call fooD(DATAN2(D1,D2)) +c FFEINTRIN_impDCOS + call fooD(DCOS(D1)) +c FFEINTRIN_impDCOSH + call fooD(DCOSH(D1)) +c FFEINTRIN_impDDIM + call fooD(DDIM(D1,D2)) +c FFEINTRIN_impDEXP + call fooD(DEXP(D1)) +c FFEINTRIN_impDIM + call fooR(DIM(R1,R2)) +c FFEINTRIN_impDINT + call fooD(DINT(D1)) +c FFEINTRIN_impDLOG + call fooD(DLOG(D1)) +c FFEINTRIN_impDLOG10 + call fooD(DLOG10(D1)) +c FFEINTRIN_impDMAX1 + call fooD(DMAX1(D1,D2)) +c FFEINTRIN_impDMIN1 + call fooD(DMIN1(D1,D2)) +c FFEINTRIN_impDMOD + call fooD(DMOD(D1,D2)) +c FFEINTRIN_impDNINT + call fooD(DNINT(D1)) +c FFEINTRIN_impDPROD + call fooD(DPROD(R1,R2)) +c FFEINTRIN_impDSIGN + call fooD(DSIGN(D1,D2)) +c FFEINTRIN_impDSIN + call fooD(DSIN(D1)) +c FFEINTRIN_impDSINH + call fooD(DSINH(D1)) +c FFEINTRIN_impDSQRT + call fooD(DSQRT(D1)) +c FFEINTRIN_impDTAN + call fooD(DTAN(D1)) +c FFEINTRIN_impDTANH + call fooD(DTANH(D1)) +c FFEINTRIN_impEXP + call fooR(EXP(R1)) +c FFEINTRIN_impIABS + call fooI(IABS(I1)) +c FFEINTRIN_impICHAR + call fooI(ICHAR(A1)) +c FFEINTRIN_impIDIM + call fooI(IDIM(I1,I2)) +c FFEINTRIN_impIDNINT + call fooI(IDNINT(D1)) +c FFEINTRIN_impINDEX + call fooI(INDEX(A1,A2)) +c FFEINTRIN_impISIGN + call fooI(ISIGN(I1,I2)) +c FFEINTRIN_impLEN + call fooI(LEN(A1)) +c FFEINTRIN_impLGE + call fooL(LGE(A1,A2)) +c FFEINTRIN_impLGT + call fooL(LGT(A1,A2)) +c FFEINTRIN_impLLE + call fooL(LLE(A1,A2)) +c FFEINTRIN_impLLT + call fooL(LLT(A1,A2)) +c FFEINTRIN_impMAX0 + call fooI(MAX0(I1,I2)) +c FFEINTRIN_impMAX1 + call fooI(MAX1(R1,R2)) +c FFEINTRIN_impMIN0 + call fooI(MIN0(I1,I2)) +c FFEINTRIN_impMIN1 + call fooI(MIN1(R1,R2)) +c FFEINTRIN_impMOD + call fooI(MOD(I1,I2)) +c FFEINTRIN_impNINT + call fooI(NINT(R1)) +c FFEINTRIN_impSIGN + call fooR(SIGN(R1,R2)) +c FFEINTRIN_impSIN + call fooR(SIN(R1)) +c FFEINTRIN_impSINH + call fooR(SINH(R1)) +c FFEINTRIN_impSQRT + call fooR(SQRT(R1)) +c FFEINTRIN_impTAN + call fooR(TAN(R1)) +c FFEINTRIN_impTANH + call fooR(TANH(R1)) +c FFEINTRIN_imp_CMPLX_C + call fooC(cmplx(C1,C2)) +c FFEINTRIN_imp_CMPLX_D + call fooZ(cmplx(D1,D2)) +c FFEINTRIN_imp_CMPLX_I + call fooC(cmplx(I1,I2)) +c FFEINTRIN_imp_CMPLX_R + call fooC(cmplx(R1,R2)) +c FFEINTRIN_imp_DBLE_C + call fooD(dble(C1)) +c FFEINTRIN_imp_DBLE_D + call fooD(dble(D1)) +c FFEINTRIN_imp_DBLE_I + call fooD(dble(I1)) +c FFEINTRIN_imp_DBLE_R + call fooD(dble(R1)) +c FFEINTRIN_imp_INT_C + call fooI(int(C1)) +c FFEINTRIN_imp_INT_D + call fooI(int(D1)) +c FFEINTRIN_imp_INT_I + call fooI(int(I1)) +c FFEINTRIN_imp_INT_R + call fooI(int(R1)) +c FFEINTRIN_imp_REAL_C + call fooR(real(C1)) +c FFEINTRIN_imp_REAL_D + call fooR(real(D1)) +c FFEINTRIN_imp_REAL_I + call fooR(real(I1)) +c FFEINTRIN_imp_REAL_R + call fooR(real(R1)) +c +c FFEINTRIN_imp_INT_D: +c +c FFEINTRIN_specIDINT + call fooI(IDINT(D1)) +c +c FFEINTRIN_imp_INT_R: +c +c FFEINTRIN_specIFIX + call fooI(IFIX(R1)) +c FFEINTRIN_specINT + call fooI(INT(R1)) +c +c FFEINTRIN_imp_REAL_D: +c +c FFEINTRIN_specSNGL + call fooR(SNGL(D1)) +c +c FFEINTRIN_imp_REAL_I: +c +c FFEINTRIN_specFLOAT + call fooR(FLOAT(I1)) +c FFEINTRIN_specREAL + call fooR(REAL(I1)) +c + end +-------- (end input file to f2c) -/* I/O buffer structure. - The `fname' field is nonzero for source files and #include files - and for the dummy text used for -D and -U. - It is zero for rescanning results of macro expansion - and for expanding macro arguments. */ -#define INPUT_STACK_MAX 400 -static struct file_buf { - char *fname; - /* Filename specified with #line command. */ - char *nominal_fname; - /* Record where in the search path this file was found. - For #include_next. */ - struct file_name_list *dir; - ffewhereLine line; - ffewhereColumn column; -} instack[INPUT_STACK_MAX]; +-------- (begin output from providing above input file as input to: +-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ +-------- -e "s:^#.*$::g"') -static int last_error_tick = 0; /* Incremented each time we print it. */ -static int input_file_stack_tick = 0; /* Incremented when status changes. */ +// -- translated by f2c (version 19950223). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +// -/* Current nesting level of input sources. - `instack[indepth]' is the level currently being read. */ -static int indepth = -1; -typedef struct file_buf FILE_BUF; +// f2c.h -- Standard Fortran to C header file // -typedef unsigned char U_CHAR; +/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." -/* table to tell if char can be part of a C identifier. */ -U_CHAR is_idchar[256]; -/* table to tell if char can be first char of a c identifier. */ -U_CHAR is_idstart[256]; -/* table to tell if c is horizontal space. */ -U_CHAR is_hor_space[256]; -/* table to tell if c is horizontal or vertical space. */ -static U_CHAR is_space[256]; + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // -#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0) -#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0) -/* Nonzero means -I- has been seen, - so don't look for #include "foo" the source-file directory. */ -static int ignore_srcdir; -#ifndef INCLUDE_LEN_FUDGE -#define INCLUDE_LEN_FUDGE 0 -#endif -static void append_include_chain (struct file_name_list *first, - struct file_name_list *last); -static FILE *open_include_file (char *filename, - struct file_name_list *searchptr); -static void print_containing_files (ffebadSeverity sev); -static const char *skip_redundant_dir_prefix (const char *); -static char *read_filename_string (int ch, FILE *f); -static struct file_name_map *read_name_map (const char *dirname); +// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // +// we assume short, float are OK // +typedef long int // long int // integer; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int // long int // logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +// typedef long long longint; // // system-dependent // -/* Append a chain of `struct file_name_list's - to the end of the main include chain. - FIRST is the beginning of the chain to append, and LAST is the end. */ -static void -append_include_chain (first, last) - struct file_name_list *first, *last; -{ - struct file_name_list *dir; - if (!first || !last) - return; - if (include == 0) - include = first; - else - last_include->next = first; +// Extern is for use with -E // - for (dir = first; ; dir = dir->next) { - int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE; - if (len > max_include_len) - max_include_len = len; - if (dir == last) - break; - } - last->next = NULL; - last_include = last; -} -/* Try to open include file FILENAME. SEARCHPTR is the directory - being tried from the include file search path. This function maps - filenames on file systems based on information read by - read_name_map. */ -static FILE * -open_include_file (filename, searchptr) - char *filename; - struct file_name_list *searchptr; -{ - register struct file_name_map *map; - register char *from; - char *p, *dir; +// I/O stuff // - if (searchptr && ! searchptr->got_name_map) - { - searchptr->name_map = read_name_map (searchptr->fname - ? searchptr->fname : "."); - searchptr->got_name_map = 1; - } - /* First check the mapping for the directory we are using. */ - if (searchptr && searchptr->name_map) - { - from = filename; - if (searchptr->fname) - from += strlen (searchptr->fname) + 1; - for (map = searchptr->name_map; map; map = map->map_next) - { - if (! strcmp (map->map_from, from)) - { - /* Found a match. */ - return fopen (map->map_to, "r"); - } - } - } - /* Try to find a mapping file for the particular directory we are - looking in. Thus #include will look up sys/types.h - in /usr/include/header.gcc and look up types.h in - /usr/include/sys/header.gcc. */ - p = rindex (filename, '/'); -#ifdef DIR_SEPARATOR - if (! p) p = rindex (filename, DIR_SEPARATOR); - else { - char *tmp = rindex (filename, DIR_SEPARATOR); - if (tmp != NULL && tmp > p) p = tmp; - } -#endif - if (! p) - p = filename; - if (searchptr - && searchptr->fname - && strlen (searchptr->fname) == (size_t) (p - filename) - && ! strncmp (searchptr->fname, filename, (int) (p - filename))) - { - /* FILENAME is in SEARCHPTR, which we've already checked. */ - return fopen (filename, "r"); - } - if (p == filename) - { - from = filename; - map = read_name_map ("."); - } - else - { - dir = (char *) xmalloc (p - filename + 1); - memcpy (dir, filename, p - filename); - dir[p - filename] = '\0'; - from = p + 1; - map = read_name_map (dir); - free (dir); - } - for (; map; map = map->map_next) - if (! strcmp (map->map_from, from)) - return fopen (map->map_to, "r"); - return fopen (filename, "r"); -} -/* Print the file names and line numbers of the #include - commands which led to the current file. */ -static void -print_containing_files (ffebadSeverity sev) -{ - FILE_BUF *ip = NULL; - int i; - int first = 1; - const char *str1; - const char *str2; - /* If stack of files hasn't changed since we last printed - this info, don't repeat it. */ - if (last_error_tick == input_file_stack_tick) - return; +typedef long int // int or long int // flag; +typedef long int // int or long int // ftnlen; +typedef long int // int or long int // ftnint; - for (i = indepth; i >= 0; i--) - if (instack[i].fname != NULL) { - ip = &instack[i]; - break; - } - /* Give up if we don't find a source file. */ - if (ip == NULL) - return; +//external read, write// +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; - /* Find the other, outer source files. */ - for (i--; i >= 0; i--) - if (instack[i].fname != NULL) - { - ip = &instack[i]; - if (first) - { - first = 0; - str1 = "In file included"; - } - else - { - str1 = "... ..."; - } +//internal read, write// +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; - if (i == 1) - str2 = ":"; - else - str2 = ""; +//open// +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; - ffebad_start_msg ("%A from %B at %0%C", sev); - ffebad_here (0, ip->line, ip->column); - ffebad_string (str1); - ffebad_string (ip->nominal_fname); - ffebad_string (str2); - ffebad_finish (); - } +//close// +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; - /* Record we have printed the status as of this time. */ - last_error_tick = input_file_stack_tick; -} +//rewind, backspace, endfile// +typedef struct +{ flag aerr; + ftnint aunit; +} alist; -/* Read a space delimited string of unlimited length from a stdio - file. */ +// inquire // +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; //parameters in standard's order// + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; -static char * -read_filename_string (ch, f) - int ch; - FILE *f; -{ - char *alloc, *set; - int len; - len = 20; - set = alloc = xmalloc (len + 1); - if (! is_space[ch]) - { - *set++ = ch; - while ((ch = getc (f)) != EOF && ! is_space[ch]) - { - if (set - alloc == len) - { - len *= 2; - alloc = xrealloc (alloc, len + 1); - set = alloc + len / 2; - } - *set++ = ch; - } - } - *set = '\0'; - ungetc (ch, f); - return alloc; -} -/* Read the file name map file for DIRNAME. */ +union Multitype { // for multiple entry points // + integer1 g; + shortint h; + integer i; + // longint j; // + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; -static struct file_name_map * -read_name_map (dirname) - const char *dirname; -{ - /* This structure holds a linked list of file name maps, one per - directory. */ - struct file_name_map_list - { - struct file_name_map_list *map_list_next; - char *map_list_name; - struct file_name_map *map_list_map; - }; - static struct file_name_map_list *map_list; - register struct file_name_map_list *map_list_ptr; - char *name; - FILE *f; - size_t dirlen; - int separator_needed; +typedef long Long; // No longer used; formerly in Namelist // - dirname = skip_redundant_dir_prefix (dirname); +struct Vardesc { // for Namelist // + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; - for (map_list_ptr = map_list; map_list_ptr; - map_list_ptr = map_list_ptr->map_list_next) - if (! strcmp (map_list_ptr->map_list_name, dirname)) - return map_list_ptr->map_list_map; +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; - map_list_ptr = ((struct file_name_map_list *) - xmalloc (sizeof (struct file_name_map_list))); - map_list_ptr->map_list_name = xstrdup (dirname); - map_list_ptr->map_list_map = NULL; - dirlen = strlen (dirname); - separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; - name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2); - strcpy (name, dirname); - name[dirlen] = '/'; - strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE); - f = fopen (name, "r"); - free (name); - if (!f) - map_list_ptr->map_list_map = NULL; - else - { - int ch; - while ((ch = getc (f)) != EOF) - { - char *from, *to; - struct file_name_map *ptr; - if (is_space[ch]) - continue; - from = read_filename_string (ch, f); - while ((ch = getc (f)) != EOF && is_hor_space[ch]) - ; - to = read_filename_string (ch, f); - ptr = ((struct file_name_map *) - xmalloc (sizeof (struct file_name_map))); - ptr->map_from = from; - /* Make the real filename absolute. */ - if (*to == '/') - ptr->map_to = to; - else - { - ptr->map_to = xmalloc (dirlen + strlen (to) + 2); - strcpy (ptr->map_to, dirname); - ptr->map_to[dirlen] = '/'; - strcpy (ptr->map_to + dirlen + separator_needed, to); - free (to); - } - ptr->map_next = map_list_ptr->map_list_map; - map_list_ptr->map_list_map = ptr; - while ((ch = getc (f)) != '\n') - if (ch == EOF) - break; - } - fclose (f); - } +// procedure parameter types for -A and -C++ // - map_list_ptr->map_list_next = map_list; - map_list = map_list_ptr; - return map_list_ptr->map_list_map; -} -static void -ffecom_file_ (char *name) -{ - FILE_BUF *fp; - /* Do partial setup of input buffer for the sake of generating - early #line directives (when -g is in effect). */ +typedef int // Unknown procedure type // (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef // Complex // void (*C_fp)(); +typedef // Double Complex // void (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef // Character // void (*H_fp)(); +typedef // Subroutine // int (*S_fp)(); - fp = &instack[++indepth]; - memset ((char *) fp, 0, sizeof (FILE_BUF)); - if (name == NULL) - name = ""; - fp->nominal_fname = fp->fname = name; -} +// E_fp is for real functions when -R is not specified // +typedef void C_f; // complex function // +typedef void H_f; // character function // +typedef void Z_f; // double complex function // +typedef doublereal E_f; // real function with -R not specified // -/* Initialize syntactic classifications of characters. */ +// undef any lower-case symbols that your C compiler predefines, e.g.: // -static void -ffecom_initialize_char_syntax_ () -{ - register int i; - /* - * Set up is_idchar and is_idstart tables. These should be - * faster than saying (is_alpha (c) || c == '_'), etc. - * Set up these things before calling any routines tthat - * refer to them. - */ - for (i = 'a'; i <= 'z'; i++) { - is_idchar[i - 'a' + 'A'] = 1; - is_idchar[i] = 1; - is_idstart[i - 'a' + 'A'] = 1; - is_idstart[i] = 1; - } - for (i = '0'; i <= '9'; i++) - is_idchar[i] = 1; - is_idchar['_'] = 1; - is_idstart['_'] = 1; +// (No such symbols should be defined in a strict ANSI C compiler. + We can avoid trouble with f2c-translated code by using + gcc -ansi [-traditional].) // + - /* horizontal space table */ - is_hor_space[' '] = 1; - is_hor_space['\t'] = 1; - is_hor_space['\v'] = 1; - is_hor_space['\f'] = 1; - is_hor_space['\r'] = 1; - is_space[' '] = 1; - is_space['\t'] = 1; - is_space['\v'] = 1; - is_space['\f'] = 1; - is_space['\n'] = 1; - is_space['\r'] = 1; -} -static void -ffecom_close_include_ (FILE *f) -{ - fclose (f); - indepth--; - input_file_stack_tick++; - ffewhere_line_kill (instack[indepth].line); - ffewhere_column_kill (instack[indepth].column); -} -static int -ffecom_decode_include_option_ (char *spec) -{ - struct file_name_list *dirtmp; - if (! ignore_srcdir && !strcmp (spec, "-")) - ignore_srcdir = 1; - else - { - dirtmp = (struct file_name_list *) - xmalloc (sizeof (struct file_name_list)); - dirtmp->next = 0; /* New one goes on the end */ - if (spec[0] != 0) - dirtmp->fname = spec; - else - fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'"); - dirtmp->got_name_map = 0; - append_include_chain (dirtmp, dirtmp); - } - return 1; -} -/* Open INCLUDEd file. */ -static FILE * -ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) -{ - char *fbeg = name; - size_t flen = strlen (fbeg); - struct file_name_list *search_start = include; /* Chain of dirs to search */ - struct file_name_list dsp[1]; /* First in chain, if #include "..." */ - struct file_name_list *searchptr = 0; - char *fname; /* Dynamically allocated fname buffer */ - FILE *f; - FILE_BUF *fp; - if (flen == 0) - return NULL; - dsp[0].fname = NULL; - /* If -I- was specified, don't search current dir, only spec'd ones. */ - if (!ignore_srcdir) - { - for (fp = &instack[indepth]; fp >= instack; fp--) - { - int n; - char *ep; - char *nam; - if ((nam = fp->nominal_fname) != NULL) - { - /* Found a named file. Figure out dir of the file, - and put it in front of the search list. */ - dsp[0].next = search_start; - search_start = dsp; -#ifndef VMS - ep = rindex (nam, '/'); -#ifdef DIR_SEPARATOR - if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR); - else { - char *tmp = rindex (nam, DIR_SEPARATOR); - if (tmp != NULL && tmp > ep) ep = tmp; - } -#endif -#else /* VMS */ - ep = rindex (nam, ']'); - if (ep == NULL) ep = rindex (nam, '>'); - if (ep == NULL) ep = rindex (nam, ':'); - if (ep != NULL) ep++; -#endif /* VMS */ - if (ep != NULL) - { - n = ep - nam; - dsp[0].fname = (char *) xmalloc (n + 1); - strncpy (dsp[0].fname, nam, n); - dsp[0].fname[n] = '\0'; - if (n + INCLUDE_LEN_FUDGE > max_include_len) - max_include_len = n + INCLUDE_LEN_FUDGE; - } - else - dsp[0].fname = NULL; /* Current directory */ - dsp[0].got_name_map = 0; - break; - } - } - } - /* Allocate this permanently, because it gets stored in the definitions - of macros. */ - fname = xmalloc (max_include_len + flen + 4); - /* + 2 above for slash and terminating null. */ - /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED - for g77 yet). */ - /* If specified file name is absolute, just open it. */ - if (*fbeg == '/' -#ifdef DIR_SEPARATOR - || *fbeg == DIR_SEPARATOR -#endif - ) - { - strncpy (fname, (char *) fbeg, flen); - fname[flen] = 0; - f = open_include_file (fname, NULL_PTR); - } - else - { - f = NULL; - /* Search directory path, trying to open the file. - Copy each filename tried into FNAME. */ - for (searchptr = search_start; searchptr; searchptr = searchptr->next) - { - if (searchptr->fname) - { - /* The empty string in a search path is ignored. - This makes it possible to turn off entirely - a standard piece of the list. */ - if (searchptr->fname[0] == 0) - continue; - strcpy (fname, skip_redundant_dir_prefix (searchptr->fname)); - if (fname[0] && fname[strlen (fname) - 1] != '/') - strcat (fname, "/"); - fname[strlen (fname) + flen] = 0; - } - else - fname[0] = 0; - strncat (fname, fbeg, flen); -#ifdef VMS - /* Change this 1/2 Unix 1/2 VMS file specification into a - full VMS file specification */ - if (searchptr->fname && (searchptr->fname[0] != 0)) - { - /* Fix up the filename */ - hack_vms_include_specification (fname); - } - else - { - /* This is a normal VMS filespec, so use it unchanged. */ - strncpy (fname, (char *) fbeg, flen); - fname[flen] = 0; -#if 0 /* Not for g77. */ - /* if it's '#include filename', add the missing .h */ - if (index (fname, '.') == NULL) - strcat (fname, ".h"); -#endif - } -#endif /* VMS */ - f = open_include_file (fname, searchptr); -#ifdef EACCES - if (f == NULL && errno == EACCES) - { - print_containing_files (FFEBAD_severityWARNING); - ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable", - FFEBAD_severityWARNING); - ffebad_string (fname); - ffebad_here (0, l, c); - ffebad_finish (); - } -#endif - if (f != NULL) - break; - } - } - if (f == NULL) - { - /* A file that was not found. */ - strncpy (fname, (char *) fbeg, flen); - fname[flen] = 0; - print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE)); - ffebad_start (FFEBAD_OPEN_INCLUDE); - ffebad_here (0, l, c); - ffebad_string (fname); - ffebad_finish (); - } - if (dsp[0].fname != NULL) - free (dsp[0].fname); +// Main program // MAIN__() +{ + // System generated locals // + integer i__1; + real r__1, r__2; + doublereal d__1, d__2; + complex q__1; + doublecomplex z__1, z__2, z__3; + logical L__1; + char ch__1[1]; + + // Builtin functions // + void c_div(); + integer pow_ii(); + double pow_ri(), pow_di(); + void pow_ci(); + double pow_dd(); + void pow_zz(); + double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), + asin(), atan(), atan2(), c_abs(); + void c_cos(), c_exp(), c_log(), r_cnjg(); + double cos(), cosh(); + void c_sin(), c_sqrt(); + double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), + d_sign(), sin(), sinh(), sqrt(), tan(), tanh(); + integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len(); + logical l_ge(), l_gt(), l_le(), l_lt(); + integer i_nint(); + double r_sign(); + + // Local variables // + extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), + fool_(), fooz_(), getem_(); + static char a1[10], a2[10]; + static complex c1, c2; + static doublereal d1, d2; + static integer i1, i2; + static real r1, r2; + + + getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); +// / // + i__1 = i1 / i2; + fooi_(&i__1); + r__1 = r1 / i1; + foor_(&r__1); + d__1 = d1 / i1; + food_(&d__1); + d__1 = (doublereal) i1; + q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; + fooc_(&q__1); + r__1 = r1 / r2; + foor_(&r__1); + d__1 = r1 / d1; + food_(&d__1); + d__1 = d1 / d2; + food_(&d__1); + d__1 = d1 / r1; + food_(&d__1); + c_div(&q__1, &c1, &c2); + fooc_(&q__1); + q__1.r = c1.r / r1, q__1.i = c1.i / r1; + fooc_(&q__1); + z__1.r = c1.r / d1, z__1.i = c1.i / d1; + fooz_(&z__1); +// ** // + i__1 = pow_ii(&i1, &i2); + fooi_(&i__1); + r__1 = pow_ri(&r1, &i1); + foor_(&r__1); + d__1 = pow_di(&d1, &i1); + food_(&d__1); + pow_ci(&q__1, &c1, &i1); + fooc_(&q__1); + d__1 = (doublereal) r1; + d__2 = (doublereal) r2; + r__1 = pow_dd(&d__1, &d__2); + foor_(&r__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d__2, &d1); + food_(&d__1); + d__1 = pow_dd(&d1, &d2); + food_(&d__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d1, &d__2); + food_(&d__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = c2.r, z__3.i = c2.i; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = r1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = d1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + fooz_(&z__1); +// FFEINTRIN_impABS // + r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; + foor_(&r__1); +// FFEINTRIN_impACOS // + r__1 = acos(r1); + foor_(&r__1); +// FFEINTRIN_impAIMAG // + r__1 = r_imag(&c1); + foor_(&r__1); +// FFEINTRIN_impAINT // + r__1 = r_int(&r1); + foor_(&r__1); +// FFEINTRIN_impALOG // + r__1 = log(r1); + foor_(&r__1); +// FFEINTRIN_impALOG10 // + r__1 = r_lg10(&r1); + foor_(&r__1); +// FFEINTRIN_impAMAX0 // + r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMAX1 // + r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN0 // + r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN1 // + r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMOD // + r__1 = r_mod(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impANINT // + r__1 = r_nint(&r1); + foor_(&r__1); +// FFEINTRIN_impASIN // + r__1 = asin(r1); + foor_(&r__1); +// FFEINTRIN_impATAN // + r__1 = atan(r1); + foor_(&r__1); +// FFEINTRIN_impATAN2 // + r__1 = atan2(r1, r2); + foor_(&r__1); +// FFEINTRIN_impCABS // + r__1 = c_abs(&c1); + foor_(&r__1); +// FFEINTRIN_impCCOS // + c_cos(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCEXP // + c_exp(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCHAR // + *(unsigned char *)&ch__1[0] = i1; + fooa_(ch__1, 1L); +// FFEINTRIN_impCLOG // + c_log(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCONJG // + r_cnjg(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCOS // + r__1 = cos(r1); + foor_(&r__1); +// FFEINTRIN_impCOSH // + r__1 = cosh(r1); + foor_(&r__1); +// FFEINTRIN_impCSIN // + c_sin(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCSQRT // + c_sqrt(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impDABS // + d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; + food_(&d__1); +// FFEINTRIN_impDACOS // + d__1 = acos(d1); + food_(&d__1); +// FFEINTRIN_impDASIN // + d__1 = asin(d1); + food_(&d__1); +// FFEINTRIN_impDATAN // + d__1 = atan(d1); + food_(&d__1); +// FFEINTRIN_impDATAN2 // + d__1 = atan2(d1, d2); + food_(&d__1); +// FFEINTRIN_impDCOS // + d__1 = cos(d1); + food_(&d__1); +// FFEINTRIN_impDCOSH // + d__1 = cosh(d1); + food_(&d__1); +// FFEINTRIN_impDDIM // + d__1 = d_dim(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDEXP // + d__1 = exp(d1); + food_(&d__1); +// FFEINTRIN_impDIM // + r__1 = r_dim(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impDINT // + d__1 = d_int(&d1); + food_(&d__1); +// FFEINTRIN_impDLOG // + d__1 = log(d1); + food_(&d__1); +// FFEINTRIN_impDLOG10 // + d__1 = d_lg10(&d1); + food_(&d__1); +// FFEINTRIN_impDMAX1 // + d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMIN1 // + d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMOD // + d__1 = d_mod(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDNINT // + d__1 = d_nint(&d1); + food_(&d__1); +// FFEINTRIN_impDPROD // + d__1 = (doublereal) r1 * r2; + food_(&d__1); +// FFEINTRIN_impDSIGN // + d__1 = d_sign(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDSIN // + d__1 = sin(d1); + food_(&d__1); +// FFEINTRIN_impDSINH // + d__1 = sinh(d1); + food_(&d__1); +// FFEINTRIN_impDSQRT // + d__1 = sqrt(d1); + food_(&d__1); +// FFEINTRIN_impDTAN // + d__1 = tan(d1); + food_(&d__1); +// FFEINTRIN_impDTANH // + d__1 = tanh(d1); + food_(&d__1); +// FFEINTRIN_impEXP // + r__1 = exp(r1); + foor_(&r__1); +// FFEINTRIN_impIABS // + i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; + fooi_(&i__1); +// FFEINTRIN_impICHAR // + i__1 = *(unsigned char *)a1; + fooi_(&i__1); +// FFEINTRIN_impIDIM // + i__1 = i_dim(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impIDNINT // + i__1 = i_dnnt(&d1); + fooi_(&i__1); +// FFEINTRIN_impINDEX // + i__1 = i_indx(a1, a2, 10L, 10L); + fooi_(&i__1); +// FFEINTRIN_impISIGN // + i__1 = i_sign(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impLEN // + i__1 = i_len(a1, 10L); + fooi_(&i__1); +// FFEINTRIN_impLGE // + L__1 = l_ge(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLGT // + L__1 = l_gt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLE // + L__1 = l_le(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLT // + L__1 = l_lt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impMAX0 // + i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMAX1 // + i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN0 // + i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN1 // + i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMOD // + i__1 = i1 % i2; + fooi_(&i__1); +// FFEINTRIN_impNINT // + i__1 = i_nint(&r1); + fooi_(&i__1); +// FFEINTRIN_impSIGN // + r__1 = r_sign(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impSIN // + r__1 = sin(r1); + foor_(&r__1); +// FFEINTRIN_impSINH // + r__1 = sinh(r1); + foor_(&r__1); +// FFEINTRIN_impSQRT // + r__1 = sqrt(r1); + foor_(&r__1); +// FFEINTRIN_impTAN // + r__1 = tan(r1); + foor_(&r__1); +// FFEINTRIN_impTANH // + r__1 = tanh(r1); + foor_(&r__1); +// FFEINTRIN_imp_CMPLX_C // + r__1 = c1.r; + r__2 = c2.r; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_D // + z__1.r = d1, z__1.i = d2; + fooz_(&z__1); +// FFEINTRIN_imp_CMPLX_I // + r__1 = (real) i1; + r__2 = (real) i2; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_R // + q__1.r = r1, q__1.i = r2; + fooc_(&q__1); +// FFEINTRIN_imp_DBLE_C // + d__1 = (doublereal) c1.r; + food_(&d__1); +// FFEINTRIN_imp_DBLE_D // + d__1 = d1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_I // + d__1 = (doublereal) i1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_R // + d__1 = (doublereal) r1; + food_(&d__1); +// FFEINTRIN_imp_INT_C // + i__1 = (integer) c1.r; + fooi_(&i__1); +// FFEINTRIN_imp_INT_D // + i__1 = (integer) d1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_I // + i__1 = i1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_R // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_imp_REAL_C // + r__1 = c1.r; + foor_(&r__1); +// FFEINTRIN_imp_REAL_D // + r__1 = (real) d1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_I // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_R // + r__1 = r1; + foor_(&r__1); + +// FFEINTRIN_imp_INT_D: // + +// FFEINTRIN_specIDINT // + i__1 = (integer) d1; + fooi_(&i__1); + +// FFEINTRIN_imp_INT_R: // + +// FFEINTRIN_specIFIX // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_specINT // + i__1 = (integer) r1; + fooi_(&i__1); + +// FFEINTRIN_imp_REAL_D: // - if (f == NULL) - return NULL; +// FFEINTRIN_specSNGL // + r__1 = (real) d1; + foor_(&r__1); - if (indepth >= (INPUT_STACK_MAX - 1)) - { - print_containing_files (FFEBAD_severityFATAL); - ffebad_start_msg ("At %0, INCLUDE nesting too deep", - FFEBAD_severityFATAL); - ffebad_string (fname); - ffebad_here (0, l, c); - ffebad_finish (); - return NULL; - } +// FFEINTRIN_imp_REAL_I: // - instack[indepth].line = ffewhere_line_use (l); - instack[indepth].column = ffewhere_column_use (c); +// FFEINTRIN_specFLOAT // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_specREAL // + r__1 = (real) i1; + foor_(&r__1); - fp = &instack[indepth + 1]; - memset ((char *) fp, 0, sizeof (FILE_BUF)); - fp->nominal_fname = fp->fname = fname; - fp->dir = searchptr; +} // MAIN__ // - indepth++; - input_file_stack_tick++; +-------- (end output file from f2c) - return f; -} -#endif /* FFECOM_GCC_INCLUDE */ +*/ diff --git a/gcc/f/com.h b/gcc/f/com.h index a438d0bdc86a..baa29533288e 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 1a74301e33c6..b89b7472d57d 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 965c465586fc..72037c13b2b1 100644 --- a/gcc/f/std.c +++ b/gcc/f/std.c @@ -192,15 +192,27 @@ 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; @@ -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 e8c066ef361f..b87f532e6a5b 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); \ + TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \ + (Init)); \ + initn = TREE_CHAIN(initn); \ } while(0) -#define ffeste_f2c_flagspec_(Flag,Init) \ - do { Init = convert (ffecom_f2c_flag_type_node, \ - Flag ? integer_one_node : integer_zero_node); } \ - while(0) +#define ffeste_f2c_prepare_charnolen_(Spec,Exp) \ + do \ + { \ + if (! (Exp)) \ + ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ + } while(0) -#define ffeste_f2c_intspec_(Spec,Exp,Init) \ +#define ffeste_f2c_prepare_char_(Spec,Exp) \ do \ { \ - if (Spec->kw_or_val_present) \ - Exp = ffecom_expr(Spec->u.expr); \ - else \ - Exp = ffecom_integer_zero_node; \ - if (TREE_CONSTANT(Exp)) \ + if (! (Exp)) \ + ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ + } while(0) + +#define ffeste_f2c_prepare_format_(Spec,Exp) \ + do \ + { \ + if (! (Exp)) \ + ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \ + } while(0) + +#define ffeste_f2c_prepare_int_(Spec,Exp) \ + do \ + { \ + if (! (Exp)) \ + ffecom_prepare_expr ((Spec)->u.expr); \ + } while(0) + +#define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \ + do \ + { \ + if (! (Exp)) \ + ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \ + } while(0) + +#define ffeste_f2c_compile_(Field,Exp) \ + do \ + { \ + tree exz; \ + if ((Exp)) \ { \ - Init = Exp; \ - Exp = NULL_TREE; \ + exz = ffecom_modify (void_type_node, \ + ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \ + t, (Field)), \ + (Exp)); \ + expand_expr_stmt (exz); \ } \ - else \ + } while(0) + +#define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \ + do \ + { \ + tree exq; \ + if (! (Exp)) \ { \ - Init = ffecom_integer_zero_node; \ - constantp = FALSE; \ + exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \ + ffeste_f2c_compile_ ((Field), exq); \ } \ } while(0) -#define ffeste_f2c_ptrtointspec_(Spec,Exp,Init) \ +#define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \ do \ { \ - if (Spec->kw_or_val_present) \ - Exp = ffecom_ptr_to_expr(Spec->u.expr); \ - else \ - Exp = null_pointer_node; \ - if (TREE_CONSTANT(Exp)) \ + tree exq = (Exp); \ + tree lenexq = (Lenexp); \ + int need_exq = (! exq); \ + int need_lenexq = (! lenexq); \ + if (need_exq || need_lenexq) \ { \ - Init = Exp; \ - Exp = NULL_TREE; \ + exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \ + if (need_exq) \ + ffeste_f2c_compile_ ((Field), exq); \ + if (need_lenexq) \ + ffeste_f2c_compile_ ((Lenfield), lenexq); \ } \ - else \ + } while(0) + +#define ffeste_f2c_compile_format_(Field,Spec,Exp) \ + do \ + { \ + tree exq; \ + if (! (Exp)) \ + { \ + exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \ + ffeste_f2c_compile_ ((Field), exq); \ + } \ + } while(0) + +#define ffeste_f2c_compile_int_(Field,Spec,Exp) \ + do \ + { \ + tree exq; \ + if (! (Exp)) \ + { \ + exq = ffecom_expr ((Spec)->u.expr); \ + ffeste_f2c_compile_ ((Field), exq); \ + } \ + } while(0) + +#define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \ + do \ + { \ + tree exq; \ + if (! (Exp)) \ { \ - Init = null_pointer_node; \ - constantp = FALSE; \ + exq = ffecom_ptr_to_expr ((Spec)->u.expr); \ + ffeste_f2c_compile_ ((Field), exq); \ } \ } while(0) +/* 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; - push_momentary (); /* Want to save these throughout the loop. */ + /* Want to have tvar, tincr, and niters for the whole loop body. */ - tvar = ffecom_expr_rw (var); + if (block) + ffeste_start_block_ (block); + else + ffeste_start_stmt_ (); + + niters = ffecom_make_tempvar (block ? "do" : "impdo", + ffecom_integer_type_node, + FFETARGET_charactersizeNONE, -1); + + ffecom_prepare_expr (incr); + ffecom_prepare_expr_rw (NULL_TREE, var); + + ffecom_prepare_end (); + + tvar = ffecom_expr_rw (NULL_TREE, var); tincr = ffecom_expr (incr); if (TREE_CODE (tvar) == ERROR_MARK || TREE_CODE (tincr) == ERROR_MARK) { if (block) - ffestw_set_do_tvar (block, error_mark_node); + { + ffeste_end_block_ (block); + ffestw_set_do_tvar (block, error_mark_node); + } else - *xtvar = error_mark_node; - pop_momentary (); + { + ffeste_end_stmt_ (); + *xtvar = error_mark_node; + } return; } @@ -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_ (); + + expanded_loop = expand_start_loop_continue_elsewhere (!! block); + if (block) + ffestw_set_do_hook (block, expanded_loop); - if (!ffe_is_onetrip ()) + if (! ffe_is_onetrip ()) { expr = ffecom_truth_value (ffecom_2 (GE_EXPR, integer_type_node, @@ -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. */ + + ffeste_f2c_init_flag_ (have_err, errinit); - unitexp = ffecom_expr (unit_expr); - if (TREE_CONSTANT (unitexp)) - { - unitinit = unitexp; - unitexp = NULL_TREE; - } + unitexp = ffecom_const_expr (unit_expr); + if (unitexp) + unitinit = unitexp; else { unitinit = ffecom_integer_zero_node; constantp = FALSE; } - ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit); + ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec); inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit); initn = inits; - ffeste_f2c_init_ (unitinit); - ffeste_f2c_init_ (statinit); + ffeste_f2c_init_next_ (unitinit); + ffeste_f2c_init_next_ (statinit); inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits); TREE_CONSTANT (inits) = constantp ? 1 : 0; @@ -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)) { - unitnuminit = unitnumexp; - unitnumexp = NULL_TREE; + /* Not an array, so just one element. */ + unitnuminit = ffecom_integer_one_node; + unitnumexp = unitnuminit; + } + else if (unitexp && unitlenexp) + { + /* An array, but all the info is constant, so compute now. */ + unitnuminit = size_binop (CEIL_DIV_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), + unitlenexp); + unitnuminit = size_binop (CEIL_DIV_EXPR, + unitnuminit, + size_int (TYPE_PRECISION + (char_type_node))); + unitnumexp = unitnuminit; } else { + /* Put off computing until run time. */ unitnuminit = ffecom_integer_zero_node; + unitnumexp = NULL_TREE; constantp = FALSE; } @@ -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); - - ttype = build_pointer_type (TREE_TYPE (t)); - t = ffecom_1 (ADDR_EXPR, ttype, t); - - t = build_tree_list (NULL_TREE, t); - - return t; -} + /* Prepare run-time expressions. */ -#endif -/* ffeste_io_impdo_ -- Handle implied-DO in I/O list + if (! unitexp) + ffecom_prepare_arg_ptr_to_expr (unit_expr); - ffebld expr; - ffeste_io_impdo_(expr); + ffeste_f2c_prepare_format_ (format_spec, formatexp); - Expands code to start up the DO loop. Then for each item in the - DO loop, handles appropriately (possibly including recursively calling - itself). Then expands code to end the DO loop. */ + ffecom_prepare_end (); -#if FFECOM_targetCURRENT == FFECOM_targetGCC -static void -ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token) -{ - ffebld var = ffebld_head (ffebld_right (impdo)); - ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo))); - ffebld end = ffebld_head (ffebld_trail (ffebld_trail - (ffebld_right (impdo)))); - ffebld incr = ffebld_head (ffebld_trail (ffebld_trail - (ffebld_trail (ffebld_right (impdo))))); - ffebld list; /* Used for list of items in left part of - impdo. */ - ffebld item; /* I/O item from head of given list. */ - tree tvar; - tree tincr; - tree titervar; + /* Now evaluate run-time expressions as needed. */ - if (incr == NULL) + if (! unitexp || ! unitlenexp) { - incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); - ffebld_set_info (incr, ffeinfo_new - (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); + int need_unitexp = (! unitexp); + int need_unitlenexp = (! unitlenexp); + + unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp); + if (need_unitexp) + ffeste_f2c_compile_ (unitfield, unitexp); + if (need_unitlenexp) + ffeste_f2c_compile_ (unitlenfield, unitlenexp); } - /* Start the DO loop. */ - - start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token, - FFEEXPR_contextLET); - end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token, - FFEEXPR_contextLET); - incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token, - FFEEXPR_contextLET); - - ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var, - start, impdo_token, - end, impdo_token, - incr, impdo_token, - "Implied DO loop"); - - /* Handle the list of items. */ - - for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list)) + if (! unitnumexp + && unitexp != error_mark_node + && unitlenexp != error_mark_node) { - item = ffebld_head (list); - if (item == NULL) - continue; - while (ffebld_op (item) == FFEBLD_opPAREN) - item = ffebld_left (item); - if (ffebld_op (item) == FFEBLD_opANY) - continue; - if (ffebld_op (item) == FFEBLD_opIMPDO) - ffeste_io_impdo_ (item, impdo_token); - else - ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE); - clear_momentary (); + unitnumexp = size_binop (CEIL_DIV_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), + unitlenexp); + unitnumexp = size_binop (CEIL_DIV_EXPR, + unitnumexp, + size_int (TYPE_PRECISION + (char_type_node))); + ffeste_f2c_compile_ (unitnumfield, unitnumexp); } - /* Generate end of implied-do construct. */ + if (format == FFESTV_formatINTEXPR) + ffeste_f2c_compile_ (formatfield, formatexp); + else + ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp); - ffeste_end_iterdo_ (tvar, tincr, titervar); -} + ttype = build_pointer_type (TREE_TYPE (t)); + t = ffecom_1 (ADDR_EXPR, ttype, t); + + t = build_tree_list (NULL_TREE, t); + return t; +} #endif -/* ffeste_io_inlist_ -- Make arglist with ptr to INQUIRE control list - tree arglist; - arglist = ffeste_io_inlist_(...); +/* Make arglist with ptr to INQUIRE control list Returns a tree suitable as an argument list containing a pointer to an INQUIRE-statement control list. First, generates that control list, if necessary, along with any static and run-time initializations - that are needed as specified by the arguments to this function. */ + that are needed as specified by the arguments to this function. + + Must ensure that all expressions are prepared before being evaluated, + for any whose evaluation might result in the generation of temporaries. + + Note that this means this function causes a transition, within the + current block being code-generated via the back end, from the + declaration of variables (temporaries) to the expanding of expressions, + statements, etc. */ #if FFECOM_targetCURRENT == FFECOM_targetGCC static tree @@ -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 +/* End of statement following logical IF. - ffeste_end_R807(TRUE); - - Applies ONLY to logical IF, not to IF-THEN. For example, does not - ffelex_token_kill the construct name for an IF-THEN block (the name - field is invalid for logical IF). ok==TRUE iff statement following - logical IF (substatement) is valid; else, statement is invalid or - stack forcibly popped due to ffeste_eof_(). */ + Applies to *only* logical IF, not to IF-THEN. */ void ffeste_end_R807 () @@ -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; + + ffeste_emit_line_note_ (); - expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); + ffeste_start_block_ (block); - ffecom_pop_calltemps (); - clear_momentary (); + temp = ffecom_make_tempvar ("ifthen", integer_type_node, + FFETARGET_charactersizeNONE, -1); + + ffeste_start_stmt_ (); + + ffecom_prepare_expr (expr); + + if (ffecom_prepare_end ()) + { + tree result; + + result = ffecom_modify (void_type_node, + temp, + ffecom_truth_value (ffecom_expr (expr))); + + expand_expr_stmt (result); + + ffeste_end_stmt_ (); + } + else + { + ffeste_end_stmt_ (); + + temp = ffecom_truth_value (ffecom_expr (expr)); + } + + expand_start_cond (temp, 0); + + /* No fake `else' constructs introduced (yet). */ + ffestw_set_ifthen_fake_else (block, 0); + } #else #error #endif } -/* ffeste_R804 -- ELSE IF statement - - ffeste_R804(expr,expr_token,name_token); - - Make sure ffeste_kind_ identifies an IF block. If not - NULL, make sure name_token gives the correct name. Implement the else - of the IF block. */ +/* ELSE IF statement. */ void -ffeste_R804 (ffebld expr) +ffeste_R804 (ffestw block, ffebld expr) { ffeste_check_simple_ (); @@ -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; + + ffeste_emit_line_note_ (); + + ffeste_start_block_ (NULL); + + temp = ffecom_make_tempvar ("if", integer_type_node, + FFETARGET_charactersizeNONE, -1); + + ffeste_start_stmt_ (); + + ffecom_prepare_expr (expr); + + if (ffecom_prepare_end ()) + { + tree result; + + result = ffecom_modify (void_type_node, + temp, + ffecom_truth_value (ffecom_expr (expr))); + + expand_expr_stmt (result); + + ffeste_end_stmt_ (); + } + else + { + ffeste_end_stmt_ (); - expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); + temp = ffecom_truth_value (ffecom_expr (expr)); + } - ffecom_pop_calltemps (); - clear_momentary (); + expand_start_cond (temp, 0); + } #else #error #endif } -/* ffeste_R809 -- SELECT CASE statement - - ffeste_R809(construct_name,expr,expr_token); - - Make sure statement is valid here; implement. */ +/* SELECT CASE statement. */ void ffeste_R809 (ffestw block, ffebld expr) @@ -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))); - ffecom_pop_calltemps (); + texpr = ffecom_modify (void_type_node, + result, + texpr); + expand_expr_stmt (texpr); + + ffeste_end_stmt_ (); + + expand_start_case (1, result, TREE_TYPE (result), + "SELECT CASE statement"); + ffestw_set_select_texpr (block, texpr); + ffestw_set_select_break (block, FALSE); + } #else #error #endif } -/* ffeste_R810 -- CASE statement - - ffeste_R810(case_value_range_list,name); +/* CASE statement. If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at the start of the first_stmt list in the select object at the top of @@ -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 */ - expand_end_case (ffestw_select_texpr (block)); - pop_momentary (); - clear_momentary (); /* ~~~handle character and character*1 */ + if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK) + expand_end_case (ffestw_select_texpr (block)); + + ffeste_end_block_ (block); #else #error #endif @@ -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 (ffeste_io_endgfrt_ != FFECOM_gfrt) + ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE, + NULL_TREE), + ! ffeste_io_abort_is_temp_); - /* if (iostat<0) goto end_label; */ + /* If we've got a temp label, generate its code here and have it fan out + to the END= or ERR= label as appropriate. */ - if ((ffeste_io_end_ != NULL_TREE) - && (TREE_CODE (ffeste_io_end_) != ERROR_MARK)) - { - expand_start_cond (ffecom_truth_value - (ffecom_2 (LT_EXPR, integer_type_node, - ffeste_io_iostat_, - ffecom_integer_zero_node)), - 0); - expand_goto (ffeste_io_end_); - expand_end_cond (); - } - - /* if (iostat>0) goto err_label; */ - - if ((ffeste_io_err_ != NULL_TREE) - && (TREE_CODE (ffeste_io_err_) != ERROR_MARK)) - { - expand_start_cond (ffecom_truth_value - (ffecom_2 (GT_EXPR, integer_type_node, - ffeste_io_iostat_, - ffecom_integer_zero_node)), - 0); - expand_goto (ffeste_io_err_); - expand_end_cond (); - } + if (ffeste_io_abort_is_temp_) + { + DECL_INITIAL (ffeste_io_abort_) = error_mark_node; + emit_nop (); + expand_label (ffeste_io_abort_); - } + /* "if (iostat<0) goto end_label;". */ - /* If we've got a temp iostat, pop the temp. */ + if ((ffeste_io_end_ != NULL_TREE) + && (TREE_CODE (ffeste_io_end_) != ERROR_MARK)) + { + expand_start_cond (ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + ffeste_io_iostat_, + ffecom_integer_zero_node)), + 0); + expand_goto (ffeste_io_end_); + expand_end_cond (); + } - if (ffeste_io_iostat_is_temp_) - ffecom_pop_tempvar (ffeste_io_iostat_); + /* "if (iostat>0) goto err_label;". */ - ffecom_pop_calltemps (); + if ((ffeste_io_err_ != NULL_TREE) + && (TREE_CODE (ffeste_io_err_) != ERROR_MARK)) + { + expand_start_cond (ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + ffeste_io_iostat_, + ffecom_integer_zero_node)), + 0); + expand_goto (ffeste_io_err_); + expand_end_cond (); + } + } - clear_momentary (); - } + ffeste_end_stmt_ (); #else #error #endif } -/* ffeste_R910_start -- WRITE(...) statement list begin - - ffeste_R910_start(); - - Verify that WRITE is valid here, and begin accepting items in the - list. */ +/* WRITE statement -- start. */ void ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, @@ -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 we've got a temp label, generate its code here. */ - - if (ffeste_io_abort_is_temp_) - { - DECL_INITIAL (ffeste_io_abort_) = error_mark_node; - emit_nop (); - expand_label (ffeste_io_abort_); - - assert (ffeste_io_err_ == NULL_TREE); - } + if (ffeste_io_endgfrt_ != FFECOM_gfrt) + ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE, + NULL_TREE), + ! ffeste_io_abort_is_temp_); - /* If we've got a temp iostat, pop the temp. */ + /* If we've got a temp label, generate its code here. */ - if (ffeste_io_iostat_is_temp_) - ffecom_pop_tempvar (ffeste_io_iostat_); + if (ffeste_io_abort_is_temp_) + { + DECL_INITIAL (ffeste_io_abort_) = error_mark_node; + emit_nop (); + expand_label (ffeste_io_abort_); - ffecom_pop_calltemps (); + assert (ffeste_io_err_ == NULL_TREE); + } - clear_momentary (); - } + ffeste_end_stmt_ (); #else #error #endif } -/* ffeste_R911_start -- PRINT statement list begin - - ffeste_R911_start(); - - Verify that PRINT is valid here, and begin accepting items in the - list. */ +/* PRINT statement -- start. */ void ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format) @@ -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=) 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 2c818759d1f1..78e98818b090 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 7a81d9b28a78..58818a61bf21 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 98b27fedbb3f..c4bd14deb99b 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 6082669ea95b..0c7262cd0a6d 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 de648d527271..807dbce5ed43 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"; -- 2.43.5