| /* ste.c -- Implementation File (module.c template V1.0) |
| Copyright (C) 1995, 1996 Free Software Foundation, Inc. |
| Contributed by James Craig Burley (burley@gnu.ai.mit.edu). |
| |
| This file is part of GNU Fortran. |
| |
| GNU Fortran is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 2, or (at your option) |
| any later version. |
| |
| GNU Fortran is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU Fortran; see the file COPYING. If not, write to |
| the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA |
| 02111-1307, USA. |
| |
| Related Modules: |
| ste.c |
| |
| Description: |
| Implements the various statements and such like. |
| |
| 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| #include "config.j" |
| #include "rtl.j" |
| #endif |
| |
| #include "proj.h" |
| #include "ste.h" |
| #include "bld.h" |
| #include "com.h" |
| #include "expr.h" |
| #include "lab.h" |
| #include "lex.h" |
| #include "sta.h" |
| #include "stp.h" |
| #include "str.h" |
| #include "sts.h" |
| #include "stt.h" |
| #include "stv.h" |
| #include "stw.h" |
| #include "symbol.h" |
| |
| /* Externals defined here. */ |
| |
| |
| /* Simple definitions and enumerations. */ |
| |
| typedef enum |
| { |
| FFESTE_stateletSIMPLE_, /* Expecting simple/start. */ |
| FFESTE_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ |
| FFESTE_stateletITEM_, /* Expecting item/itemstart/finish. */ |
| FFESTE_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ |
| FFESTE_ |
| } ffesteStatelet_; |
| |
| /* Internal typedefs. */ |
| |
| |
| /* Private include files. */ |
| |
| |
| /* Internal structure definitions. */ |
| |
| |
| /* Static objects accessed by functions in this module. */ |
| |
| static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_; |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static ffelab ffeste_label_formatdef_ = NULL; |
| static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */ |
| static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */ |
| static tree ffeste_io_abort_; /* abort-io label or NULL_TREE. */ |
| static bool ffeste_io_abort_is_temp_; /* abort-io label is a temp. */ |
| static tree ffeste_io_end_; /* END= label or NULL_TREE. */ |
| static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */ |
| static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */ |
| static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */ |
| #endif |
| |
| /* Static functions (internal). */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr, |
| tree *xitersvar, ffebld var, |
| ffebld start, ffelexToken start_token, |
| ffebld end, ffelexToken end_token, |
| ffebld incr, ffelexToken incr_token, |
| char *msg); |
| static void ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar); |
| static void ffeste_io_call_ (tree call, bool do_check); |
| static tree ffeste_io_dofio_ (ffebld expr); |
| static tree ffeste_io_dolio_ (ffebld expr); |
| static tree ffeste_io_douio_ (ffebld expr); |
| static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit, |
| ffebld unit_expr, int unit_dflt); |
| static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit, |
| ffebld unit_expr, int unit_dflt, |
| bool have_end, ffestvFormat format, |
| ffestpFile *format_spec, bool rec, |
| ffebld rec_expr); |
| static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr, |
| ffestpFile *stat_spec); |
| 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_olist_ (bool have_err, ffebld unit_expr, |
| ffestpFile *file_spec, |
| ffestpFile *stat_spec, |
| ffestpFile *access_spec, |
| ffestpFile *form_spec, |
| ffestpFile *recl_spec, |
| ffestpFile *blank_spec); |
| static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt); |
| #elif FFECOM_targetCURRENT == FFECOM_targetFFE |
| static void ffeste_subr_file_ (char *kw, ffestpFile *spec); |
| #else |
| #error |
| #endif |
| |
| /* Internal macros. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| #define ffeste_emit_line_note_() \ |
| emit_line_note (input_filename, lineno) |
| #endif |
| #define ffeste_check_simple_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_) |
| #define ffeste_check_start_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \ |
| ffeste_statelet_ = FFESTE_stateletATTRIB_ |
| #define ffeste_check_attrib_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletATTRIB_) |
| #define ffeste_check_item_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ |
| || ffeste_statelet_ == FFESTE_stateletITEM_); \ |
| ffeste_statelet_ = FFESTE_stateletITEM_ |
| #define ffeste_check_item_startvals_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ |
| || ffeste_statelet_ == FFESTE_stateletITEM_); \ |
| ffeste_statelet_ = FFESTE_stateletITEMVALS_ |
| #define ffeste_check_item_value_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_) |
| #define ffeste_check_item_endvals_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \ |
| ffeste_statelet_ = FFESTE_stateletITEM_ |
| #define ffeste_check_finish_() \ |
| assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \ |
| || ffeste_statelet_ == FFESTE_stateletITEM_); \ |
| ffeste_statelet_ = FFESTE_stateletSIMPLE_ |
| |
| #define ffeste_f2c_charnolenspec_(Spec,Exp,Init) \ |
| do \ |
| { \ |
| if (Spec->kw_or_val_present) \ |
| Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&ignore); \ |
| else \ |
| Exp = null_pointer_node; \ |
| if (TREE_CONSTANT(Exp)) \ |
| { \ |
| Init = Exp; \ |
| Exp = NULL_TREE; \ |
| } \ |
| else \ |
| { \ |
| Init = null_pointer_node; \ |
| constantp = FALSE; \ |
| } \ |
| } while(0) |
| |
| #define ffeste_f2c_charspec_(Spec,Exp,Init,Lenexp,Leninit) \ |
| do \ |
| { \ |
| if (Spec->kw_or_val_present) \ |
| Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&Lenexp); \ |
| else \ |
| { \ |
| Exp = null_pointer_node; \ |
| Lenexp = ffecom_f2c_ftnlen_zero_node; \ |
| } \ |
| if (TREE_CONSTANT(Exp)) \ |
| { \ |
| Init = Exp; \ |
| Exp = NULL_TREE; \ |
| } \ |
| else \ |
| { \ |
| Init = null_pointer_node; \ |
| constantp = FALSE; \ |
| } \ |
| if ((Lenexp != NULL_TREE) && TREE_CONSTANT(Lenexp)) \ |
| { \ |
| Leninit = Lenexp; \ |
| Lenexp = NULL_TREE; \ |
| } \ |
| else \ |
| { \ |
| Leninit = ffecom_f2c_ftnlen_zero_node; \ |
| constantp = FALSE; \ |
| } \ |
| } while(0) |
| |
| #define ffeste_f2c_exp_(Field,Exp) \ |
| do \ |
| { \ |
| if (Exp != NULL_TREE) \ |
| { \ |
| Exp = ffecom_modify(void_type_node,ffecom_2(COMPONENT_REF, \ |
| TREE_TYPE(Field),t,Field),Exp); \ |
| expand_expr_stmt(Exp); \ |
| } \ |
| } while(0) |
| |
| #define ffeste_f2c_init_(Init) \ |
| do \ |
| { \ |
| 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_intspec_(Spec,Exp,Init) \ |
| do \ |
| { \ |
| if (Spec->kw_or_val_present) \ |
| Exp = ffecom_expr(Spec->u.expr); \ |
| else \ |
| Exp = ffecom_integer_zero_node; \ |
| if (TREE_CONSTANT(Exp)) \ |
| { \ |
| Init = Exp; \ |
| Exp = NULL_TREE; \ |
| } \ |
| else \ |
| { \ |
| Init = ffecom_integer_zero_node; \ |
| constantp = FALSE; \ |
| } \ |
| } while(0) |
| |
| #define ffeste_f2c_ptrtointspec_(Spec,Exp,Init) \ |
| do \ |
| { \ |
| if (Spec->kw_or_val_present) \ |
| Exp = ffecom_ptr_to_expr(Spec->u.expr); \ |
| else \ |
| Exp = null_pointer_node; \ |
| if (TREE_CONSTANT(Exp)) \ |
| { \ |
| Init = Exp; \ |
| Exp = NULL_TREE; \ |
| } \ |
| else \ |
| { \ |
| Init = null_pointer_node; \ |
| constantp = FALSE; \ |
| } \ |
| } while(0) |
| |
| |
| /* Begin an iterative DO loop. Pass the block to start if applicable. |
| |
| NOTE: Does _two_ push_momentary () calls, which the caller must |
| undo (by calling ffeste_end_iterdo_). */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static void |
| ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr, |
| tree *xitersvar, ffebld var, |
| ffebld start, ffelexToken start_token, |
| ffebld end, ffelexToken end_token, |
| ffebld incr, ffelexToken incr_token, |
| char *msg) |
| { |
| tree tvar; |
| tree expr; |
| tree tstart; |
| tree tend; |
| tree tincr; |
| tree tincr_saved; |
| tree niters; |
| |
| push_momentary (); /* Want to save these throughout the loop. */ |
| |
| tvar = ffecom_expr_rw (var); |
| tincr = ffecom_expr (incr); |
| |
| /* Check whether incr is known to be zero, complain and fix. */ |
| |
| if (integer_zerop (tincr) || real_zerop (tincr)) |
| { |
| ffebad_start (FFEBAD_DO_STEP_ZERO); |
| ffebad_here (0, ffelex_token_where_line (incr_token), |
| ffelex_token_where_column (incr_token)); |
| ffebad_string (msg); |
| ffebad_finish (); |
| tincr = convert (TREE_TYPE (tvar), integer_one_node); |
| } |
| |
| tincr_saved = ffecom_save_tree (tincr); |
| |
| push_momentary (); /* Want to discard the rest after the loop. */ |
| |
| tstart = ffecom_expr (start); |
| tend = ffecom_expr (end); |
| |
| { /* For warnings only, nothing else |
| happens here. */ |
| tree try; |
| |
| if (!ffe_is_onetrip ()) |
| { |
| try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar), |
| tend, |
| tstart); |
| |
| try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), |
| try, |
| tincr); |
| |
| if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE) |
| try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try, |
| tincr); |
| else |
| try = convert (integer_type_node, |
| ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar), |
| try, |
| tincr)); |
| |
| /* Warn if loop never executed, since we've done the evaluation |
| of the unofficial iteration count already. */ |
| |
| try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node, |
| try, |
| convert (TREE_TYPE (tvar), |
| integer_zero_node))); |
| |
| if (integer_onep (try)) |
| { |
| ffebad_start (FFEBAD_DO_NULL); |
| ffebad_here (0, ffelex_token_where_line (start_token), |
| ffelex_token_where_column (start_token)); |
| ffebad_string (msg); |
| ffebad_finish (); |
| } |
| } |
| |
| /* Warn if end plus incr would overflow. */ |
| |
| try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), |
| tend, |
| tincr); |
| |
| if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c') |
| && TREE_CONSTANT_OVERFLOW (try)) |
| { |
| ffebad_start (FFEBAD_DO_END_OVERFLOW); |
| ffebad_here (0, ffelex_token_where_line (end_token), |
| ffelex_token_where_column (end_token)); |
| ffebad_string (msg); |
| ffebad_finish (); |
| } |
| } |
| |
| /* Do the initial assignment into the DO var. */ |
| |
| expr = ffecom_modify (void_type_node, tvar, tstart); |
| expand_expr_stmt (expr); |
| |
| expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar), |
| tend, |
| TREE_CONSTANT (tstart) ? tstart : tvar); |
| |
| if (!ffe_is_onetrip ()) |
| { |
| expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr), |
| expr, |
| convert (TREE_TYPE (expr), tincr_saved)); |
| } |
| |
| if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE) |
| expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr), |
| expr, |
| tincr_saved); |
| else |
| expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr), |
| expr, |
| tincr_saved); |
| |
| #if 1 /* New, F90-approved approach: convert to default INTEGER. */ |
| if (TREE_TYPE (tvar) != error_mark_node) |
| expr = convert (ffecom_integer_type_node, expr); |
| #else /* Old approach; convert to INTEGER unless that's a narrowing. */ |
| if ((TREE_TYPE (tvar) != error_mark_node) |
| && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE) |
| || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE) |
| && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar))) |
| != INTEGER_CST) |
| || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar))) |
| <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node))))))) |
| /* Convert unless promoting INTEGER type of any kind downward to |
| default INTEGER; else leave as, say, INTEGER*8 (long long int). */ |
| expr = convert (ffecom_integer_type_node, expr); |
| #endif |
| |
| niters = ffecom_push_tempvar (TREE_TYPE (expr), |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| expr = ffecom_modify (void_type_node, niters, expr); |
| 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)); |
| |
| if (!ffe_is_onetrip ()) |
| { |
| expr = ffecom_truth_value |
| (ffecom_2 (GE_EXPR, integer_type_node, |
| ffecom_2 (PREDECREMENT_EXPR, |
| TREE_TYPE (niters), |
| niters, |
| convert (TREE_TYPE (niters), |
| ffecom_integer_one_node)), |
| convert (TREE_TYPE (niters), |
| ffecom_integer_zero_node))); |
| |
| expand_exit_loop_if_false (0, expr); |
| } |
| |
| clear_momentary (); /* Discard the above now that we're done with |
| DO stmt. */ |
| |
| if (block == NULL) |
| { |
| *xtvar = tvar; |
| *xtincr = tincr_saved; |
| *xitersvar = niters; |
| } |
| else |
| { |
| ffestw_set_do_tvar (block, tvar); |
| ffestw_set_do_incr_saved (block, tincr_saved); |
| ffestw_set_do_count_var (block, niters); |
| } |
| } |
| |
| #endif |
| |
| /* End an iterative DO loop. Pass the same iteration variable and increment |
| value trees that were generated in the paired _begin_ call. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static void |
| ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar) |
| { |
| tree expr; |
| tree niters = itersvar; |
| |
| expand_loop_continue_here (); |
| |
| if (ffe_is_onetrip ()) |
| { |
| expr = ffecom_truth_value |
| (ffecom_2 (GE_EXPR, integer_type_node, |
| ffecom_2 (PREDECREMENT_EXPR, |
| TREE_TYPE (niters), |
| niters, |
| convert (TREE_TYPE (niters), |
| ffecom_integer_one_node)), |
| convert (TREE_TYPE (niters), |
| ffecom_integer_zero_node))); |
| |
| expand_exit_loop_if_false (0, expr); |
| } |
| |
| expr = ffecom_modify (void_type_node, tvar, |
| ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar), |
| tvar, |
| tincr)); |
| expand_expr_stmt (expr); |
| expand_end_loop (); |
| |
| ffecom_pop_tempvar (itersvar); /* Free #iters var. */ |
| |
| clear_momentary (); |
| pop_momentary (); /* Lose the stuff we just built. */ |
| |
| clear_momentary (); |
| pop_momentary (); /* Lose the tvar and incr_saved trees. */ |
| } |
| |
| #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_;". */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static void |
| ffeste_io_call_ (tree call, bool do_check) |
| { |
| /* Generate the call and optional assignment into iostat var. */ |
| |
| 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); |
| } |
| expand_expr_stmt (call); |
| |
| if (!do_check |
| || (ffeste_io_abort_ == NULL_TREE) |
| || (TREE_CODE (ffeste_io_abort_) == ERROR_MARK)) |
| return; |
| |
| /* Generate optional test. */ |
| |
| expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0); |
| expand_goto (ffeste_io_abort_); |
| expand_end_cond (); |
| } |
| |
| #endif |
| /* ffeste_io_dofio_ -- Generate call to do_fio for formatted I/O item |
| |
| ffebld expr; |
| tree call; |
| call = ffeste_io_dofio_(expr); |
| |
| 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 |
| the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag |
| for the CALL_EXPR, expand (emit) the expression, emit any assignment |
| of the result to an IOSTAT= variable, and emit any checking of the |
| result for errors. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_dofio_ (ffebld expr) |
| { |
| tree num_elements; |
| tree variable; |
| tree size; |
| tree arglist; |
| ffeinfoBasictype bt; |
| ffeinfoKindtype kt; |
| bool is_complex; |
| |
| bt = ffeinfo_basictype (ffebld_info (expr)); |
| kt = ffeinfo_kindtype (ffebld_info (expr)); |
| |
| if ((bt == FFEINFO_basictypeANY) |
| || (kt == FFEINFO_kindtypeANY)) |
| return error_mark_node; |
| |
| if (bt == FFEINFO_basictypeCOMPLEX) |
| { |
| is_complex = TRUE; |
| bt = FFEINFO_basictypeREAL; |
| } |
| 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; |
| } |
| |
| if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ |
| { /* "(ftnlen) sizeof(type)" */ |
| size = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (ffecom_tree_type[bt][kt]), |
| size_int (TYPE_PRECISION (char_type_node))); |
| #if 0 /* Assume that while it is possible that char * is wider than |
| ftnlen, no object in Fortran space can get big enough for its |
| size to be wider than ftnlen. I really hope nobody wastes |
| time debugging a case where it can! */ |
| assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) |
| >= TYPE_PRECISION (TREE_TYPE (size))); |
| #endif |
| 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; |
| else |
| { |
| num_elements = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size); |
| num_elements = size_binop (CEIL_DIV_EXPR, num_elements, |
| size_int (TYPE_PRECISION |
| (char_type_node))); |
| num_elements = convert (ffecom_f2c_ftnlen_type_node, |
| num_elements); |
| } |
| |
| num_elements |
| = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, |
| num_elements); |
| |
| variable = convert (string_type_node, variable); |
| |
| arglist = build_tree_list (NULL_TREE, num_elements); |
| 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); |
| } |
| |
| #endif |
| /* ffeste_io_dolio_ -- Generate call to do_lio for list-directed I/O item |
| |
| ffebld expr; |
| tree call; |
| call = ffeste_io_dolio_(expr); |
| |
| 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 |
| the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag |
| for the CALL_EXPR, expand (emit) the expression, emit any assignment |
| of the result to an IOSTAT= variable, and emit any checking of the |
| result for errors. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_dolio_ (ffebld expr) |
| { |
| tree type_id; |
| tree num_elements; |
| tree variable; |
| tree size; |
| tree arglist; |
| ffeinfoBasictype bt; |
| ffeinfoKindtype kt; |
| int tc; |
| |
| bt = ffeinfo_basictype (ffebld_info (expr)); |
| kt = ffeinfo_kindtype (ffebld_info (expr)); |
| |
| if ((bt == FFEINFO_basictypeANY) |
| || (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); |
| |
| type_id |
| = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node, |
| convert (ffecom_f2c_ftnint_type_node, |
| type_id)); |
| |
| variable = ffecom_arg_ptr_to_expr (expr, &size); |
| |
| if ((type_id == error_mark_node) |
| || (variable == error_mark_node) |
| || (size == error_mark_node)) |
| { |
| ffecom_pop_calltemps (); |
| return error_mark_node; |
| } |
| |
| if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ |
| { /* "(ftnlen) sizeof(type)" */ |
| size = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (ffecom_tree_type[bt][kt]), |
| size_int (TYPE_PRECISION (char_type_node))); |
| #if 0 /* Assume that while it is possible that char * is wider than |
| ftnlen, no object in Fortran space can get big enough for its |
| size to be wider than ftnlen. I really hope nobody wastes |
| time debugging a case where it can! */ |
| assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) |
| >= TYPE_PRECISION (TREE_TYPE (size))); |
| #endif |
| 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 = ffecom_integer_one_node; |
| else |
| { |
| num_elements = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size); |
| num_elements = size_binop (CEIL_DIV_EXPR, |
| num_elements, size_int (TYPE_PRECISION |
| (char_type_node))); |
| num_elements = convert (ffecom_f2c_ftnlen_type_node, |
| num_elements); |
| } |
| |
| num_elements |
| = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, |
| num_elements); |
| |
| variable = convert (string_type_node, variable); |
| |
| arglist = build_tree_list (NULL_TREE, type_id); |
| TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements); |
| TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable); |
| TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist))) |
| = build_tree_list (NULL_TREE, size); |
| |
| ffecom_pop_calltemps (); |
| |
| return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist); |
| } |
| |
| #endif |
| /* ffeste_io_douio_ -- Generate call to do_uio for unformatted I/O item |
| |
| ffebld expr; |
| tree call; |
| call = ffeste_io_douio_(expr); |
| |
| 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 |
| the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag |
| for the CALL_EXPR, expand (emit) the expression, emit any assignment |
| of the result to an IOSTAT= variable, and emit any checking of the |
| result for errors. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_douio_ (ffebld expr) |
| { |
| tree num_elements; |
| tree variable; |
| tree size; |
| tree arglist; |
| ffeinfoBasictype bt; |
| ffeinfoKindtype kt; |
| bool is_complex; |
| |
| bt = ffeinfo_basictype (ffebld_info (expr)); |
| kt = ffeinfo_kindtype (ffebld_info (expr)); |
| |
| if ((bt == FFEINFO_basictypeANY) |
| || (kt == FFEINFO_kindtypeANY)) |
| return error_mark_node; |
| |
| if (bt == FFEINFO_basictypeCOMPLEX) |
| { |
| is_complex = TRUE; |
| bt = FFEINFO_basictypeREAL; |
| } |
| 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; |
| } |
| |
| if (size == NULL_TREE) /* Already filled in for CHARACTER type. */ |
| { /* "(ftnlen) sizeof(type)" */ |
| size = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (ffecom_tree_type[bt][kt]), |
| size_int (TYPE_PRECISION (char_type_node))); |
| #if 0 /* Assume that while it is possible that char * is wider than |
| ftnlen, no object in Fortran space can get big enough for its |
| size to be wider than ftnlen. I really hope nobody wastes |
| time debugging a case where it can! */ |
| assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) |
| >= TYPE_PRECISION (TREE_TYPE (size))); |
| #endif |
| 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; |
| else |
| { |
| num_elements = size_binop (CEIL_DIV_EXPR, |
| TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size); |
| num_elements = size_binop (CEIL_DIV_EXPR, num_elements, |
| size_int (TYPE_PRECISION |
| (char_type_node))); |
| num_elements = convert (ffecom_f2c_ftnlen_type_node, |
| num_elements); |
| } |
| |
| num_elements |
| = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, |
| num_elements); |
| |
| variable = convert (string_type_node, variable); |
| |
| arglist = build_tree_list (NULL_TREE, num_elements); |
| 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); |
| } |
| |
| #endif |
| /* ffeste_io_ialist_ -- Make arglist with ptr to B/E/R control list |
| |
| tree arglist; |
| arglist = ffeste_io_ialist_(...); |
| |
| 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_ialist_ (bool have_err, |
| ffestvUnit unit, |
| ffebld unit_expr, |
| int unit_dflt) |
| { |
| static tree f2c_alist_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| bool constantp = TRUE; |
| static tree errfield, unitfield; |
| tree errinit, unitinit; |
| tree unitexp; |
| static int mynumber = 0; |
| |
| if (f2c_alist_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| ffecom_f2c_ftnint_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| f2c_alist_struct = ref; |
| } |
| |
| ffeste_f2c_flagspec_ (have_err, errinit); |
| |
| switch (unit) |
| { |
| case FFESTV_unitNONE: |
| case FFESTV_unitASTERISK: |
| unitinit = build_int_2 (unit_dflt, 0); |
| unitexp = NULL_TREE; |
| break; |
| |
| case FFESTV_unitINTEXPR: |
| unitexp = ffecom_expr (unit_expr); |
| if (TREE_CONSTANT (unitexp)) |
| { |
| unitinit = unitexp; |
| unitexp = NULL_TREE; |
| } |
| else |
| { |
| unitinit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| break; |
| |
| default: |
| assert ("bad unit spec" == NULL); |
| unitexp = NULL_TREE; |
| unitinit = ffecom_integer_zero_node; |
| break; |
| } |
| |
| inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit); |
| initn = inits; |
| ffeste_f2c_init_ (unitinit); |
| |
| inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_alist_%d", NULL, |
| mynumber++), |
| f2c_alist_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| |
| 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_cilist_ -- Make arglist with ptr to external I/O control list |
| |
| tree arglist; |
| arglist = ffeste_io_cilist_(...); |
| |
| Returns a tree suitable as an argument list containing a pointer to |
| an external-file 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_cilist_ (bool have_err, |
| ffestvUnit unit, |
| ffebld unit_expr, |
| int unit_dflt, |
| bool have_end, |
| ffestvFormat format, |
| ffestpFile *format_spec, |
| bool rec, |
| ffebld rec_expr) |
| { |
| static tree f2c_cilist_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| tree ignore; /* We ignore the length of format! */ |
| bool constantp = TRUE; |
| static tree errfield, unitfield, endfield, formatfield, recfield; |
| tree errinit, unitinit, endinit, formatinit, recinit; |
| tree unitexp, formatexp, recexp; |
| static int mynumber = 0; |
| |
| if (f2c_cilist_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| ffecom_f2c_ftnint_type_node); |
| endfield = ffecom_decl_field (ref, unitfield, "end", |
| ffecom_f2c_flag_type_node); |
| formatfield = ffecom_decl_field (ref, endfield, "format", |
| string_type_node); |
| recfield = ffecom_decl_field (ref, formatfield, "rec", |
| ffecom_f2c_ftnint_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| f2c_cilist_struct = ref; |
| } |
| |
| ffeste_f2c_flagspec_ (have_err, errinit); |
| |
| switch (unit) |
| { |
| case FFESTV_unitNONE: |
| case FFESTV_unitASTERISK: |
| unitinit = build_int_2 (unit_dflt, 0); |
| unitexp = NULL_TREE; |
| break; |
| |
| case FFESTV_unitINTEXPR: |
| unitexp = ffecom_expr (unit_expr); |
| if (TREE_CONSTANT (unitexp)) |
| { |
| unitinit = unitexp; |
| unitexp = NULL_TREE; |
| } |
| else |
| { |
| unitinit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| break; |
| |
| default: |
| assert ("bad unit spec" == NULL); |
| unitexp = NULL_TREE; |
| unitinit = ffecom_integer_zero_node; |
| break; |
| } |
| |
| switch (format) |
| { |
| case FFESTV_formatNONE: |
| formatinit = null_pointer_node; |
| formatexp = NULL_TREE; |
| break; |
| |
| case FFESTV_formatLABEL: |
| formatexp = NULL_TREE; |
| formatinit = ffecom_lookup_label (format_spec->u.label); |
| if ((formatinit == NULL_TREE) |
| || (TREE_CODE (formatinit) == ERROR_MARK)) |
| break; |
| formatinit = ffecom_1 (ADDR_EXPR, |
| build_pointer_type (void_type_node), |
| formatinit); |
| TREE_CONSTANT (formatinit) = 1; |
| break; |
| |
| case FFESTV_formatCHAREXPR: |
| formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore); |
| if (TREE_CONSTANT (formatexp)) |
| { |
| formatinit = formatexp; |
| formatexp = NULL_TREE; |
| } |
| else |
| { |
| formatinit = null_pointer_node; |
| constantp = FALSE; |
| } |
| break; |
| |
| case FFESTV_formatASTERISK: |
| formatinit = null_pointer_node; |
| formatexp = NULL_TREE; |
| break; |
| |
| case FFESTV_formatINTEXPR: |
| formatinit = null_pointer_node; |
| formatexp = ffecom_expr_assign (format_spec->u.expr); |
| if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp))) |
| < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) |
| error ("ASSIGNed FORMAT specifier is too small"); |
| formatexp = convert (string_type_node, formatexp); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| formatinit = ffecom_expr (format_spec->u.expr); |
| formatexp = NULL_TREE; |
| break; |
| |
| default: |
| assert ("bad format spec" == NULL); |
| formatexp = NULL_TREE; |
| formatinit = integer_zero_node; |
| break; |
| } |
| |
| ffeste_f2c_flagspec_ (have_end, endinit); |
| |
| if (rec) |
| recexp = ffecom_expr (rec_expr); |
| else |
| recexp = ffecom_integer_zero_node; |
| if (TREE_CONSTANT (recexp)) |
| { |
| recinit = recexp; |
| recexp = NULL_TREE; |
| } |
| else |
| { |
| recinit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| |
| 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); |
| |
| inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_cilist_%d", NULL, |
| mynumber++), |
| f2c_cilist_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| ffeste_f2c_exp_ (formatfield, formatexp); |
| ffeste_f2c_exp_ (recfield, recexp); |
| |
| 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_cllist_ -- Make arglist with ptr to CLOSE control list |
| |
| tree arglist; |
| arglist = ffeste_io_cllist_(...); |
| |
| 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_cllist_ (bool have_err, |
| ffebld unit_expr, |
| ffestpFile *stat_spec) |
| { |
| static tree f2c_close_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| tree ignore; /* Ignore length info for certain fields. */ |
| bool constantp = TRUE; |
| static tree errfield, unitfield, statfield; |
| tree errinit, unitinit, statinit; |
| tree unitexp, statexp; |
| static int mynumber = 0; |
| |
| if (f2c_close_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| ffecom_f2c_ftnint_type_node); |
| statfield = ffecom_decl_field (ref, unitfield, "stat", |
| string_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| f2c_close_struct = ref; |
| } |
| |
| ffeste_f2c_flagspec_ (have_err, errinit); |
| |
| unitexp = ffecom_expr (unit_expr); |
| if (TREE_CONSTANT (unitexp)) |
| { |
| unitinit = unitexp; |
| unitexp = NULL_TREE; |
| } |
| else |
| { |
| unitinit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| |
| ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit); |
| |
| inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit); |
| initn = inits; |
| ffeste_f2c_init_ (unitinit); |
| ffeste_f2c_init_ (statinit); |
| |
| inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_cllist_%d", NULL, |
| mynumber++), |
| f2c_close_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| ffeste_f2c_exp_ (statfield, statexp); |
| |
| 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_icilist_ -- Make arglist with ptr to internal I/O control list |
| |
| tree arglist; |
| arglist = ffeste_io_icilist_(...); |
| |
| Returns a tree suitable as an argument list containing a pointer to |
| an internal-file 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_icilist_ (bool have_err, |
| ffebld unit_expr, |
| bool have_end, |
| ffestvFormat format, |
| ffestpFile *format_spec) |
| { |
| static tree f2c_icilist_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| tree ignore; /* We ignore the length of format! */ |
| bool constantp = TRUE; |
| static tree errfield, unitfield, endfield, formatfield, unitlenfield, |
| unitnumfield; |
| tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit; |
| tree unitexp, formatexp, unitlenexp, unitnumexp; |
| static int mynumber = 0; |
| |
| if (f2c_icilist_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| string_type_node); |
| endfield = ffecom_decl_field (ref, unitfield, "end", |
| ffecom_f2c_flag_type_node); |
| formatfield = ffecom_decl_field (ref, endfield, "format", |
| string_type_node); |
| unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen", |
| ffecom_f2c_ftnint_type_node); |
| unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum", |
| ffecom_f2c_ftnint_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| f2c_icilist_struct = ref; |
| } |
| |
| ffeste_f2c_flagspec_ (have_err, errinit); |
| |
| 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; |
| } |
| else |
| { |
| unitinit = null_pointer_node; |
| constantp = FALSE; |
| } |
| if ((unitlenexp != NULL_TREE) && TREE_CONSTANT (unitlenexp)) |
| { |
| unitleninit = unitlenexp; |
| unitlenexp = NULL_TREE; |
| } |
| else |
| { |
| unitleninit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| if (TREE_CONSTANT (unitnumexp)) |
| { |
| unitnuminit = unitnumexp; |
| unitnumexp = NULL_TREE; |
| } |
| else |
| { |
| unitnuminit = ffecom_integer_zero_node; |
| constantp = FALSE; |
| } |
| |
| switch (format) |
| { |
| case FFESTV_formatNONE: |
| formatinit = null_pointer_node; |
| formatexp = NULL_TREE; |
| break; |
| |
| case FFESTV_formatLABEL: |
| formatexp = NULL_TREE; |
| formatinit = ffecom_lookup_label (format_spec->u.label); |
| if ((formatinit == NULL_TREE) |
| || (TREE_CODE (formatinit) == ERROR_MARK)) |
| break; |
| formatinit = ffecom_1 (ADDR_EXPR, |
| build_pointer_type (void_type_node), |
| formatinit); |
| TREE_CONSTANT (formatinit) = 1; |
| break; |
| |
| case FFESTV_formatCHAREXPR: |
| formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore); |
| if (TREE_CONSTANT (formatexp)) |
| { |
| formatinit = formatexp; |
| formatexp = NULL_TREE; |
| } |
| else |
| { |
| formatinit = null_pointer_node; |
| constantp = FALSE; |
| } |
| break; |
| |
| case FFESTV_formatASTERISK: |
| formatinit = null_pointer_node; |
| formatexp = NULL_TREE; |
| break; |
| |
| case FFESTV_formatINTEXPR: |
| formatinit = null_pointer_node; |
| formatexp = ffecom_expr_assign (format_spec->u.expr); |
| if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp))) |
| < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) |
| error ("ASSIGNed FORMAT specifier is too small"); |
| formatexp = convert (string_type_node, formatexp); |
| break; |
| |
| default: |
| assert ("bad format spec" == NULL); |
| formatexp = NULL_TREE; |
| formatinit = ffecom_integer_zero_node; |
| break; |
| } |
| |
| ffeste_f2c_flagspec_ (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); |
| |
| inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_icilist_%d", NULL, |
| mynumber++), |
| f2c_icilist_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| ffeste_f2c_exp_ (formatfield, formatexp); |
| ffeste_f2c_exp_ (unitlenfield, unitlenexp); |
| ffeste_f2c_exp_ (unitnumfield, unitnumexp); |
| |
| ttype = build_pointer_type (TREE_TYPE (t)); |
| t = ffecom_1 (ADDR_EXPR, ttype, t); |
| |
| t = build_tree_list (NULL_TREE, t); |
| |
| return t; |
| } |
| |
| #endif |
| /* ffeste_io_impdo_ -- Handle implied-DO in I/O list |
| |
| ffebld expr; |
| ffeste_io_impdo_(expr); |
| |
| 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; /* 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; |
| |
| 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; |
| 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 (); |
| } |
| |
| /* Generate end of implied-do construct. */ |
| |
| ffeste_end_iterdo_ (tvar, tincr, titervar); |
| } |
| |
| #endif |
| /* ffeste_io_inlist_ -- Make arglist with ptr to INQUIRE control list |
| |
| tree arglist; |
| arglist = ffeste_io_inlist_(...); |
| |
| 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| 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 f2c_inquire_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| bool constantp = TRUE; |
| static tree errfield, unitfield, filefield, filelenfield, existfield, |
| openfield, numberfield, namedfield, namefield, namelenfield, accessfield, |
| accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield, |
| formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield, |
| unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield; |
| tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit, |
| namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit, |
| sequentialleninit, directinit, directleninit, forminit, formleninit, |
| formattedinit, formattedleninit, unformattedinit, unformattedleninit, |
| reclinit, nextrecinit, blankinit, blankleninit; |
| tree |
| unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp, |
| nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp, |
| directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp, |
| unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp; |
| static int mynumber = 0; |
| |
| if (f2c_inquire_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| ffecom_f2c_ftnint_type_node); |
| filefield = ffecom_decl_field (ref, unitfield, "file", |
| string_type_node); |
| filelenfield = ffecom_decl_field (ref, filefield, "filelen", |
| ffecom_f2c_ftnlen_type_node); |
| existfield = ffecom_decl_field (ref, filelenfield, "exist", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| openfield = ffecom_decl_field (ref, existfield, "open", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| numberfield = ffecom_decl_field (ref, openfield, "number", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| namedfield = ffecom_decl_field (ref, numberfield, "named", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| namefield = ffecom_decl_field (ref, namedfield, "name", |
| string_type_node); |
| namelenfield = ffecom_decl_field (ref, namefield, "namelen", |
| ffecom_f2c_ftnlen_type_node); |
| accessfield = ffecom_decl_field (ref, namelenfield, "access", |
| string_type_node); |
| accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen", |
| ffecom_f2c_ftnlen_type_node); |
| sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential", |
| string_type_node); |
| sequentiallenfield = ffecom_decl_field (ref, sequentialfield, |
| "sequentiallen", |
| ffecom_f2c_ftnlen_type_node); |
| directfield = ffecom_decl_field (ref, sequentiallenfield, "direct", |
| string_type_node); |
| directlenfield = ffecom_decl_field (ref, directfield, "directlen", |
| ffecom_f2c_ftnlen_type_node); |
| formfield = ffecom_decl_field (ref, directlenfield, "form", |
| string_type_node); |
| formlenfield = ffecom_decl_field (ref, formfield, "formlen", |
| ffecom_f2c_ftnlen_type_node); |
| formattedfield = ffecom_decl_field (ref, formlenfield, "formatted", |
| string_type_node); |
| formattedlenfield = ffecom_decl_field (ref, formattedfield, |
| "formattedlen", |
| ffecom_f2c_ftnlen_type_node); |
| unformattedfield = ffecom_decl_field (ref, formattedlenfield, |
| "unformatted", |
| string_type_node); |
| unformattedlenfield = ffecom_decl_field (ref, unformattedfield, |
| "unformattedlen", |
| ffecom_f2c_ftnlen_type_node); |
| reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec", |
| ffecom_f2c_ptr_to_ftnint_type_node); |
| blankfield = ffecom_decl_field (ref, nextrecfield, "blank", |
| string_type_node); |
| blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen", |
| ffecom_f2c_ftnlen_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| 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); |
| |
| 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); |
| |
| inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_inlist_%d", NULL, |
| mynumber++), |
| f2c_inquire_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| ffeste_f2c_exp_ (filefield, fileexp); |
| ffeste_f2c_exp_ (filelenfield, filelenexp); |
| ffeste_f2c_exp_ (existfield, existexp); |
| ffeste_f2c_exp_ (openfield, openexp); |
| ffeste_f2c_exp_ (numberfield, numberexp); |
| ffeste_f2c_exp_ (namedfield, namedexp); |
| ffeste_f2c_exp_ (namefield, nameexp); |
| ffeste_f2c_exp_ (namelenfield, namelenexp); |
| ffeste_f2c_exp_ (accessfield, accessexp); |
| ffeste_f2c_exp_ (accesslenfield, accesslenexp); |
| ffeste_f2c_exp_ (sequentialfield, sequentialexp); |
| ffeste_f2c_exp_ (sequentiallenfield, sequentiallenexp); |
| ffeste_f2c_exp_ (directfield, directexp); |
| ffeste_f2c_exp_ (directlenfield, directlenexp); |
| ffeste_f2c_exp_ (formfield, formexp); |
| ffeste_f2c_exp_ (formlenfield, formlenexp); |
| ffeste_f2c_exp_ (formattedfield, formattedexp); |
| ffeste_f2c_exp_ (formattedlenfield, formattedlenexp); |
| ffeste_f2c_exp_ (unformattedfield, unformattedexp); |
| ffeste_f2c_exp_ (unformattedlenfield, unformattedlenexp); |
| ffeste_f2c_exp_ (reclfield, reclexp); |
| ffeste_f2c_exp_ (nextrecfield, nextrecexp); |
| ffeste_f2c_exp_ (blankfield, blankexp); |
| ffeste_f2c_exp_ (blanklenfield, blanklenexp); |
| |
| 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_olist_ -- Make arglist with ptr to OPEN control list |
| |
| tree arglist; |
| arglist = ffeste_io_olist_(...); |
| |
| 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. */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static tree |
| ffeste_io_olist_ (bool have_err, |
| ffebld unit_expr, |
| ffestpFile *file_spec, |
| ffestpFile *stat_spec, |
| ffestpFile *access_spec, |
| ffestpFile *form_spec, |
| ffestpFile *recl_spec, |
| ffestpFile *blank_spec) |
| { |
| static tree f2c_open_struct = NULL_TREE; |
| tree t; |
| tree ttype; |
| int yes; |
| tree field; |
| tree inits, initn; |
| tree ignore; /* Ignore length info for certain fields. */ |
| bool constantp = TRUE; |
| static tree errfield, unitfield, filefield, filelenfield, statfield, |
| accessfield, formfield, reclfield, blankfield; |
| tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit, |
| forminit, reclinit, blankinit; |
| tree |
| unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp, |
| blankexp; |
| static int mynumber = 0; |
| |
| if (f2c_open_struct == NULL_TREE) |
| { |
| tree ref; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| ref = make_node (RECORD_TYPE); |
| |
| errfield = ffecom_decl_field (ref, NULL_TREE, "err", |
| ffecom_f2c_flag_type_node); |
| unitfield = ffecom_decl_field (ref, errfield, "unit", |
| ffecom_f2c_ftnint_type_node); |
| filefield = ffecom_decl_field (ref, unitfield, "file", |
| string_type_node); |
| filelenfield = ffecom_decl_field (ref, filefield, "filelen", |
| ffecom_f2c_ftnlen_type_node); |
| statfield = ffecom_decl_field (ref, filelenfield, "stat", |
| string_type_node); |
| accessfield = ffecom_decl_field (ref, statfield, "access", |
| string_type_node); |
| formfield = ffecom_decl_field (ref, accessfield, "form", |
| string_type_node); |
| reclfield = ffecom_decl_field (ref, formfield, "recl", |
| ffecom_f2c_ftnint_type_node); |
| blankfield = ffecom_decl_field (ref, reclfield, "blank", |
| string_type_node); |
| |
| TYPE_FIELDS (ref) = errfield; |
| layout_type (ref); |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| f2c_open_struct = ref; |
| } |
| |
| ffeste_f2c_flagspec_ (have_err, errinit); |
| |
| unitexp = ffecom_expr (unit_expr); |
| if (TREE_CONSTANT (unitexp)) |
| { |
| unitinit = unitexp; |
| unitexp = NULL_TREE; |
| } |
| 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); |
| |
| 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); |
| |
| inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits); |
| TREE_CONSTANT (inits) = constantp ? 1 : 0; |
| TREE_STATIC (inits) = 1; |
| |
| yes = suspend_momentary (); |
| |
| t = build_decl (VAR_DECL, |
| ffecom_get_invented_identifier ("__g77_olist_%d", NULL, |
| mynumber++), |
| f2c_open_struct); |
| TREE_STATIC (t) = 1; |
| t = ffecom_start_decl (t, 1); |
| ffecom_finish_decl (t, inits, 0); |
| |
| resume_momentary (yes); |
| |
| ffeste_f2c_exp_ (unitfield, unitexp); |
| ffeste_f2c_exp_ (filefield, fileexp); |
| ffeste_f2c_exp_ (filelenfield, filelenexp); |
| ffeste_f2c_exp_ (statfield, statexp); |
| ffeste_f2c_exp_ (accessfield, accessexp); |
| ffeste_f2c_exp_ (formfield, formexp); |
| ffeste_f2c_exp_ (reclfield, reclexp); |
| ffeste_f2c_exp_ (blankfield, blankexp); |
| |
| 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_subr_file_ -- Display file-statement specifier |
| |
| ffeste_subr_file_(&specifier); */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| static void |
| ffeste_subr_file_ (char *kw, ffestpFile *spec) |
| { |
| if (!spec->kw_or_val_present) |
| return; |
| fputs (kw, dmpout); |
| if (spec->value_present) |
| { |
| fputc ('=', dmpout); |
| if (spec->value_is_label) |
| { |
| assert (spec->value_is_label == 2); /* Temporary checking only. */ |
| fprintf (dmpout, "%" ffelabValue_f "u", |
| ffelab_value (spec->u.label)); |
| } |
| else |
| ffebld_dump (spec->u.expr); |
| } |
| fputc (',', dmpout); |
| } |
| #endif |
| |
| /* ffeste_subr_beru_ -- Generate code for BACKSPACE/ENDFILE/REWIND |
| |
| ffeste_subr_beru_(FFECOM_gfrtFBACK); */ |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetGCC |
| static void |
| ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt) |
| { |
| tree alist; |
| bool iostat; |
| bool errl; |
| |
| #define specified(something) (info->beru_spec[something].kw_or_val_present) |
| |
| ffeste_emit_line_note_ (); |
| |
| /* Do the real work. */ |
| |
| iostat = specified (FFESTP_beruixIOSTAT); |
| errl = specified (FFESTP_beruixERR); |
| |
| /* ~~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 |
| construct. When it is time to add this feature to the FFE, which |
| probably is fairly easy, ffestc_R919 and company will want to pass an |
| 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. */ |
| |
| ffecom_push_calltemps (); |
| |
| alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR, |
| info->beru_spec[FFESTP_beruixUNIT].u.expr, 6); |
| |
| if (errl) |
| { /* ERR= */ |
| ffeste_io_err_ |
| = ffeste_io_abort_ |
| = ffecom_lookup_label |
| (info->beru_spec[FFESTP_beruixERR].u.label); |
| ffeste_io_abort_is_temp_ = FALSE; |
| } |
| else |
| { /* no ERR= */ |
| ffeste_io_err_ = NULL_TREE; |
| |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| 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= */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, or ERR= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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_); |
| |
| /* If we've got a temp label, generate its code here. */ |
| |
| if (ffeste_io_abort_is_temp_) |
| { |
| DECL_INITIAL (ffeste_io_abort_) = error_mark_node; |
| emit_nop (); |
| expand_label (ffeste_io_abort_); |
| |
| assert (ffeste_io_err_ == NULL_TREE); |
| } |
| |
| /* If we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| #undef specified |
| |
| clear_momentary (); |
| } |
| |
| #endif |
| /* ffeste_do -- End of statement following DO-term-stmt etc |
| |
| ffeste_do(TRUE); |
| |
| 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. */ |
| |
| void |
| ffeste_do (ffestw block) |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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. */ |
| else |
| ffeste_end_iterdo_ (ffestw_do_tvar (block), |
| ffestw_do_incr_saved (block), |
| ffestw_do_count_var (block)); |
| |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_end_R807 -- End of statement following logical IF |
| |
| ffeste_end_R807(TRUE); |
| |
| 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_(). */ |
| |
| void |
| ffeste_end_R807 () |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */ |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| expand_end_cond (); |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_labeldef_branch -- Generate "code" for branch label def |
| |
| ffeste_labeldef_branch(label); */ |
| |
| void |
| ffeste_labeldef_branch (ffelab label) |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "+ label %lu\n", ffelab_value (label)); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree glabel; |
| |
| glabel = ffecom_lookup_label (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 |
| #error |
| #endif |
| } |
| |
| /* ffeste_labeldef_format -- Generate "code" for FORMAT label def |
| |
| ffeste_labeldef_format(label); */ |
| |
| void |
| ffeste_labeldef_format (ffelab label) |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "$ label %lu\n", ffelab_value (label)); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_label_formatdef_ = label; |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R737A -- Assignment statement outside of WHERE |
| |
| ffeste_R737A(dest_expr,source_expr); */ |
| |
| void |
| ffeste_R737A (ffebld dest, ffebld source) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ let ", dmpout); |
| ffebld_dump (dest); |
| fputs ("=", dmpout); |
| ffebld_dump (source); |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| ffecom_expand_let_stmt (dest, source); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R803 -- Block IF (IF-THEN) statement |
| |
| ffeste_R803(construct_name,expr,expr_token); |
| |
| Make sure statement is valid here; implement. */ |
| |
| void |
| ffeste_R803 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ IF_block (", dmpout); |
| ffebld_dump (expr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| #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. */ |
| |
| void |
| ffeste_R804 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ ELSE_IF (", dmpout); |
| ffebld_dump (expr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| expand_start_elseif (ffecom_truth_value (ffecom_expr (expr))); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| #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. */ |
| |
| void |
| ffeste_R805 () |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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); */ |
| |
| void |
| ffeste_R806 () |
| { |
| #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 (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R807 -- Logical IF statement |
| |
| ffeste_R807(expr,expr_token); |
| |
| Make sure statement is valid here; implement. */ |
| |
| void |
| ffeste_R807 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ IF_logical (", dmpout); |
| ffebld_dump (expr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R809 -- SELECT CASE statement |
| |
| ffeste_R809(construct_name,expr,expr_token); |
| |
| Make sure statement is valid here; implement. */ |
| |
| void |
| ffeste_R809 (ffestw block, ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ SELECT_CASE (", dmpout); |
| ffebld_dump (expr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffecom_push_calltemps (); |
| |
| { |
| tree texpr; |
| |
| ffeste_emit_line_note_ (); |
| |
| 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); |
| } |
| } |
| } |
| |
| ffecom_pop_calltemps (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R810 -- CASE statement |
| |
| ffeste_R810(case_value_range_list,name); |
| |
| 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 |
| the stack that match casenum. */ |
| |
| void |
| ffeste_R810 (ffestw block, unsigned long casenum) |
| { |
| ffestwSelect s = ffestw_select (block); |
| ffestwCase c; |
| |
| ffeste_check_simple_ (); |
| |
| if (s->first_stmt == (ffestwCase) &s->first_rel) |
| c = NULL; |
| else |
| c = s->first_stmt; |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if ((c == NULL) || (casenum != c->casenum)) |
| { |
| if (casenum == 0) /* Intentional CASE DEFAULT. */ |
| fputs ("+ CASE_DEFAULT", dmpout); |
| } |
| else |
| { |
| bool comma = FALSE; |
| |
| fputs ("+ CASE (", dmpout); |
| do |
| { |
| if (comma) |
| fputc (',', dmpout); |
| else |
| comma = TRUE; |
| if (c->low != NULL) |
| ffebld_constant_dump (c->low); |
| if (c->low != c->high) |
| { |
| fputc (':', dmpout); |
| if (c->high != NULL) |
| ffebld_constant_dump (c->high); |
| } |
| c = c->next_stmt; |
| /* Unlink prev. */ |
| c->previous_stmt->previous_stmt->next_stmt = c; |
| c->previous_stmt = c->previous_stmt->previous_stmt; |
| } |
| while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum)); |
| fputc (')', dmpout); |
| } |
| |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree texprlow; |
| tree texprhigh; |
| tree tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); |
| int pushok; |
| tree duplicate; |
| |
| ffeste_emit_line_note_ (); |
| |
| if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK) |
| { |
| clear_momentary (); |
| return; |
| } |
| |
| if (ffestw_select_break (block)) |
| expand_exit_something (); |
| else |
| ffestw_set_select_break (block, TRUE); |
| |
| if ((c == NULL) || (casenum != c->casenum)) |
| { |
| if (casenum == 0) /* Intentional CASE DEFAULT. */ |
| { |
| pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate); |
| assert (pushok == 0); |
| } |
| } |
| else |
| do |
| { |
| texprlow = (c->low == NULL) ? NULL_TREE |
| : ffecom_constantunion (&ffebld_constant_union (c->low), s->type, |
| s->kindtype, ffecom_tree_type[s->type][s->kindtype]); |
| if (c->low != c->high) |
| { |
| texprhigh = (c->high == NULL) ? NULL_TREE |
| : ffecom_constantunion (&ffebld_constant_union (c->high), |
| s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]); |
| pushok = pushcase_range (texprlow, texprhigh, convert, |
| tlabel, &duplicate); |
| } |
| else |
| pushok = pushcase (texprlow, convert, tlabel, &duplicate); |
| assert (pushok == 0); |
| c = c->next_stmt; |
| /* Unlink prev. */ |
| c->previous_stmt->previous_stmt->next_stmt = c; |
| c->previous_stmt = c->previous_stmt->previous_stmt; |
| } |
| 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); */ |
| |
| void |
| ffeste_R811 (ffestw block) |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ END_SELECT\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_emit_line_note_ (); |
| |
| if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK) |
| { |
| clear_momentary (); |
| return; |
| } |
| |
| expand_end_case (ffestw_select_texpr (block)); |
| pop_momentary (); |
| clear_momentary (); /* ~~~handle character and character*1 */ |
| #else |
| #error |
| #endif |
| } |
| |
| /* Iterative DO statement. */ |
| |
| void |
| ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var, |
| ffebld start, ffelexToken start_token, |
| ffebld end, ffelexToken end_token, |
| ffebld incr, ffelexToken incr_token) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if ((ffebld_op (incr) == FFEBLD_opCONTER) |
| && (ffebld_constant_is_zero (ffebld_conter (incr)))) |
| { |
| ffebad_start (FFEBAD_DO_STEP_ZERO); |
| ffebad_here (0, ffelex_token_where_line (incr_token), |
| ffelex_token_where_column (incr_token)); |
| ffebad_string ("Iterative DO loop"); |
| ffebad_finish (); |
| /* Don't bother replacing it with 1 yet. */ |
| } |
| |
| if (label == NULL) |
| fputs ("+ DO_iterative_nonlabeled (", dmpout); |
| else |
| fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label)); |
| ffebld_dump (var); |
| fputc ('=', dmpout); |
| ffebld_dump (start); |
| fputc (',', dmpout); |
| ffebld_dump (end); |
| fputc (',', dmpout); |
| ffebld_dump (incr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| /* Start the DO loop. */ |
| |
| ffeste_begin_iterdo_ (block, NULL, NULL, NULL, |
| var, |
| start, start_token, |
| 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. */ |
| |
| void |
| ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if (label == NULL) |
| fputs ("+ DO_WHILE_nonlabeled (", dmpout); |
| else |
| fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label)); |
| ffebld_dump (expr); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| 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))); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| } |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R825 -- END DO statement |
| |
| ffeste_R825(name_token); |
| |
| 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. */ |
| |
| void |
| ffeste_R825 () |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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. */ |
| |
| void |
| ffeste_R834 (ffestw block) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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. */ |
| |
| void |
| ffeste_R835 (ffestw block) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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. */ |
| |
| void |
| ffeste_R836 (ffelab label) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label)); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| 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 (); |
| } |
| } |
| #else |
| #error |
| #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. */ |
| |
| void |
| ffeste_R837 (ffelab *labels, int count, ffebld expr) |
| { |
| int i; |
| |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ CGOTO (", dmpout); |
| for (i = 0; i < count; ++i) |
| { |
| if (i != 0) |
| fputc (',', dmpout); |
| fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i])); |
| } |
| fputs ("),", dmpout); |
| ffebld_dump (expr); |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree texpr; |
| tree value; |
| tree tlabel; |
| int pushok; |
| tree duplicate; |
| |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| 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); |
| tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); |
| |
| 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 (); |
| } |
| pop_momentary (); |
| expand_end_case (texpr); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| } |
| #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. */ |
| |
| void |
| ffeste_R838 (ffelab label, ffebld target) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label)); |
| ffebld_dump (target); |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree expr_tree; |
| tree label_tree; |
| tree target_tree; |
| |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| label_tree = ffecom_lookup_label (label); |
| if ((label_tree != NULL_TREE) |
| && (TREE_CODE (label_tree) != ERROR_MARK)) |
| { |
| label_tree = ffecom_1 (ADDR_EXPR, |
| 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. */ |
| |
| void |
| ffeste_R839 (ffebld target) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ AGOTO ", dmpout); |
| ffebld_dump (target); |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree t; |
| |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| 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 |
| #error |
| #endif |
| } |
| |
| /* ffeste_R840 -- Arithmetic IF statement |
| |
| ffeste_R840(expr,expr_token,neg,zero,pos); |
| |
| Make sure the labels are valid; implement. */ |
| |
| void |
| ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ IF_arithmetic (", dmpout); |
| ffebld_dump (expr); |
| fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n", |
| ffelab_value (neg), ffelab_value (zero), ffelab_value (pos)); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree gneg = ffecom_lookup_label (neg); |
| tree gzero = ffecom_lookup_label (zero); |
| tree gpos = ffecom_lookup_label (pos); |
| tree texpr; |
| |
| if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE)) |
| return; |
| if ((TREE_CODE (gneg) == ERROR_MARK) |
| || (TREE_CODE (gzero) == ERROR_MARK) |
| || (TREE_CODE (gpos) == ERROR_MARK)) |
| return; |
| |
| ffecom_push_calltemps (); |
| |
| if (neg == zero) |
| if (neg == pos) |
| expand_goto (gzero); |
| else |
| { /* IF (expr.LE.0) THEN GOTO neg/zero ELSE |
| GOTO pos. */ |
| texpr = ffecom_expr (expr); |
| texpr = ffecom_2 (LE_EXPR, integer_type_node, |
| texpr, |
| convert (TREE_TYPE (texpr), |
| integer_zero_node)); |
| expand_start_cond (ffecom_truth_value (texpr), 0); |
| expand_goto (gzero); |
| expand_start_else (); |
| expand_goto (gpos); |
| expand_end_cond (); |
| } |
| else if (neg == pos) |
| { /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO |
| zero. */ |
| texpr = ffecom_expr (expr); |
| texpr = ffecom_2 (NE_EXPR, integer_type_node, |
| texpr, |
| convert (TREE_TYPE (texpr), |
| integer_zero_node)); |
| expand_start_cond (ffecom_truth_value (texpr), 0); |
| expand_goto (gneg); |
| expand_start_else (); |
| expand_goto (gzero); |
| expand_end_cond (); |
| } |
| else if (zero == pos) |
| { /* IF (expr.GE.0) THEN GOTO zero/pos ELSE |
| GOTO neg. */ |
| texpr = ffecom_expr (expr); |
| texpr = ffecom_2 (GE_EXPR, integer_type_node, |
| texpr, |
| convert (TREE_TYPE (texpr), |
| integer_zero_node)); |
| expand_start_cond (ffecom_truth_value (texpr), 0); |
| expand_goto (gzero); |
| expand_start_else (); |
| expand_goto (gneg); |
| 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. */ |
| tree expr_saved = ffecom_save_tree (ffecom_expr (expr)); |
| |
| texpr = ffecom_2 (LT_EXPR, integer_type_node, |
| expr_saved, |
| convert (TREE_TYPE (expr_saved), |
| integer_zero_node)); |
| expand_start_cond (ffecom_truth_value (texpr), 0); |
| expand_goto (gneg); |
| texpr = ffecom_2 (GT_EXPR, integer_type_node, |
| expr_saved, |
| convert (TREE_TYPE (expr_saved), |
| integer_zero_node)); |
| expand_start_elseif (ffecom_truth_value (texpr)); |
| expand_goto (gpos); |
| expand_start_else (); |
| expand_goto (gzero); |
| expand_end_cond (); |
| } |
| ffeste_emit_line_note_ (); |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| } |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R841 -- CONTINUE statement |
| |
| ffeste_R841(); */ |
| |
| void |
| ffeste_R841 () |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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); */ |
| |
| void |
| ffeste_R842 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if (expr == NULL) |
| { |
| fputs ("+ STOP\n", dmpout); |
| } |
| else |
| { |
| fputs ("+ STOP_coded ", dmpout); |
| ffebld_dump (expr); |
| fputc ('\n', dmpout); |
| } |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree callit; |
| ffelexToken msg; |
| |
| ffeste_emit_line_note_ (); |
| if ((expr == NULL) |
| || (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeANY)) |
| { |
| msg = ffelex_token_new_character ("", ffelex_token_where_line |
| (ffesta_tokens[0]), ffelex_token_where_column |
| (ffesta_tokens[0])); |
| expr = ffebld_new_conter (ffebld_constant_new_characterdefault |
| (msg)); |
| ffelex_token_kill (msg); |
| ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, |
| FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, |
| FFEINFO_whereCONSTANT, 0)); |
| } |
| else if (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeINTEGER) |
| { |
| char num[50]; |
| |
| assert (ffebld_op (expr) == FFEBLD_opCONTER); |
| assert (ffeinfo_kindtype (ffebld_info (expr)) |
| == FFEINFO_kindtypeINTEGERDEFAULT); |
| sprintf (num, "%" ffetargetIntegerDefault_f "d", |
| ffebld_constant_integer1 (ffebld_conter (expr))); |
| msg = ffelex_token_new_character (num, ffelex_token_where_line |
| (ffesta_tokens[0]), ffelex_token_where_column |
| (ffesta_tokens[0])); |
| expr = ffebld_new_conter (ffebld_constant_new_characterdefault |
| (msg)); |
| ffelex_token_kill (msg); |
| ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, |
| FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, |
| FFEINFO_whereCONSTANT, 0)); |
| } |
| else |
| { |
| assert (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeCHARACTER); |
| assert (ffebld_op (expr) == FFEBLD_opCONTER); |
| assert (ffeinfo_kindtype (ffebld_info (expr)) |
| == FFEINFO_kindtypeCHARACTERDEFAULT); |
| } |
| |
| ffecom_push_calltemps (); |
| callit = ffecom_call_gfrt (FFECOM_gfrtSTOP, |
| ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL))); |
| ffecom_pop_calltemps (); |
| TREE_SIDE_EFFECTS (callit) = 1; |
| expand_expr_stmt (callit); |
| clear_momentary (); |
| } |
| #else |
| #error |
| #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. */ |
| |
| void |
| ffeste_R843 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if (expr == NULL) |
| { |
| fputs ("+ PAUSE\n", dmpout); |
| } |
| else |
| { |
| fputs ("+ PAUSE_coded ", dmpout); |
| ffebld_dump (expr); |
| fputc ('\n', dmpout); |
| } |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree callit; |
| ffelexToken msg; |
| |
| ffeste_emit_line_note_ (); |
| if ((expr == NULL) |
| || (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeANY)) |
| { |
| msg = ffelex_token_new_character ("", ffelex_token_where_line |
| (ffesta_tokens[0]), ffelex_token_where_column |
| (ffesta_tokens[0])); |
| expr = ffebld_new_conter (ffebld_constant_new_characterdefault |
| (msg)); |
| ffelex_token_kill (msg); |
| ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, |
| FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, |
| FFEINFO_whereCONSTANT, 0)); |
| } |
| else if (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeINTEGER) |
| { |
| char num[50]; |
| |
| assert (ffebld_op (expr) == FFEBLD_opCONTER); |
| assert (ffeinfo_kindtype (ffebld_info (expr)) |
| == FFEINFO_kindtypeINTEGERDEFAULT); |
| sprintf (num, "%" ffetargetIntegerDefault_f "d", |
| ffebld_constant_integer1 (ffebld_conter (expr))); |
| msg = ffelex_token_new_character (num, ffelex_token_where_line |
| (ffesta_tokens[0]), ffelex_token_where_column |
| (ffesta_tokens[0])); |
| expr = ffebld_new_conter (ffebld_constant_new_characterdefault |
| (msg)); |
| ffelex_token_kill (msg); |
| ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, |
| FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, |
| FFEINFO_whereCONSTANT, 0)); |
| } |
| else |
| { |
| assert (ffeinfo_basictype (ffebld_info (expr)) |
| == FFEINFO_basictypeCHARACTER); |
| assert (ffebld_op (expr) == FFEBLD_opCONTER); |
| assert (ffeinfo_kindtype (ffebld_info (expr)) |
| == FFEINFO_kindtypeCHARACTERDEFAULT); |
| } |
| |
| ffecom_push_calltemps (); |
| callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE, |
| ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL))); |
| ffecom_pop_calltemps (); |
| TREE_SIDE_EFFECTS (callit) = 1; |
| expand_expr_stmt (callit); |
| clear_momentary (); |
| } |
| #if 0 /* Old approach for phantom g77 run-time |
| library. */ |
| { |
| tree callit; |
| |
| ffeste_emit_line_note_ (); |
| if (expr == NULL) |
| callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, 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 (); |
| } |
| 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 (); |
| } |
| TREE_SIDE_EFFECTS (callit) = 1; |
| expand_expr_stmt (callit); |
| clear_momentary (); |
| } |
| #endif |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R904 -- OPEN statement |
| |
| ffeste_R904(); |
| |
| Make sure an OPEN is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_R904 (ffestpOpenStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ OPEN (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]); |
| ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]); |
| ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]); |
| ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]); |
| ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]); |
| ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]); |
| ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]); |
| ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]); |
| ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]); |
| ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]); |
| ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]); |
| ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]); |
| ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]); |
| ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]); |
| ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]); |
| ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]); |
| ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]); |
| ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]); |
| ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]); |
| ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]); |
| ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]); |
| ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]); |
| ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]); |
| ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]); |
| ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]); |
| ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]); |
| ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]); |
| ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]); |
| ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree args; |
| bool iostat; |
| bool errl; |
| |
| #define specified(something) (info->open_spec[something].kw_or_val_present) |
| |
| ffeste_emit_line_note_ (); |
| |
| iostat = specified (FFESTP_openixIOSTAT); |
| errl = specified (FFESTP_openixERR); |
| |
| ffecom_push_calltemps (); |
| |
| 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]); |
| |
| if (errl) |
| { |
| ffeste_io_err_ |
| = ffeste_io_abort_ |
| = ffecom_lookup_label |
| (info->open_spec[FFESTP_openixERR].u.label); |
| ffeste_io_abort_is_temp_ = FALSE; |
| } |
| else |
| { |
| ffeste_io_err_ = NULL_TREE; |
| |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| 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= */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, or ERR= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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_); |
| |
| /* If we've got a temp label, generate its code here. */ |
| |
| if (ffeste_io_abort_is_temp_) |
| { |
| DECL_INITIAL (ffeste_io_abort_) = error_mark_node; |
| emit_nop (); |
| expand_label (ffeste_io_abort_); |
| |
| assert (ffeste_io_err_ == NULL_TREE); |
| } |
| |
| /* If we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| #undef specified |
| } |
| |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R907 -- CLOSE statement |
| |
| ffeste_R907(); |
| |
| Make sure a CLOSE is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_R907 (ffestpCloseStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ CLOSE (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]); |
| ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]); |
| ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree args; |
| bool iostat; |
| bool errl; |
| |
| #define specified(something) (info->close_spec[something].kw_or_val_present) |
| |
| ffeste_emit_line_note_ (); |
| |
| iostat = specified (FFESTP_closeixIOSTAT); |
| errl = specified (FFESTP_closeixERR); |
| |
| ffecom_push_calltemps (); |
| |
| args = ffeste_io_cllist_ (errl || iostat, |
| info->close_spec[FFESTP_closeixUNIT].u.expr, |
| &info->close_spec[FFESTP_closeixSTATUS]); |
| |
| if (errl) |
| { |
| ffeste_io_err_ |
| = ffeste_io_abort_ |
| = ffecom_lookup_label |
| (info->close_spec[FFESTP_closeixERR].u.label); |
| ffeste_io_abort_is_temp_ = FALSE; |
| } |
| else |
| { |
| ffeste_io_err_ = NULL_TREE; |
| |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| 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= */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, or ERR= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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_); |
| |
| /* If we've got a temp label, generate its code here. */ |
| |
| if (ffeste_io_abort_is_temp_) |
| { |
| DECL_INITIAL (ffeste_io_abort_) = error_mark_node; |
| emit_nop (); |
| expand_label (ffeste_io_abort_); |
| |
| assert (ffeste_io_err_ == NULL_TREE); |
| } |
| |
| /* If we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| #undef specified |
| } |
| |
| 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. */ |
| |
| void |
| ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED, |
| ffestvUnit unit, ffestvFormat format, bool rec, |
| bool key UNUSED) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatNONE: |
| if (rec) |
| fputs ("+ READ_ufdac", dmpout); |
| else if (key) |
| fputs ("+ READ_ufidx", dmpout); |
| else |
| fputs ("+ READ_ufseq", dmpout); |
| break; |
| |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| if (rec) |
| fputs ("+ READ_fmdac", dmpout); |
| else if (key) |
| fputs ("+ READ_fmidx", dmpout); |
| else if (unit == FFESTV_unitCHAREXPR) |
| fputs ("+ READ_fmint", dmpout); |
| else |
| fputs ("+ READ_fmseq", dmpout); |
| break; |
| |
| case FFESTV_formatASTERISK: |
| if (unit == FFESTV_unitCHAREXPR) |
| fputs ("+ READ_lsint", dmpout); |
| else |
| fputs ("+ READ_lsseq", dmpout); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| fputs ("+ READ_nlseq", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in R909 READ" == NULL); |
| } |
| |
| if (only_format) |
| { |
| fputc (' ', dmpout); |
| ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]); |
| fputc (' ', dmpout); |
| |
| return; |
| } |
| |
| fputs (" (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]); |
| ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]); |
| ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]); |
| ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]); |
| ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]); |
| ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]); |
| ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]); |
| ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]); |
| ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]); |
| ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]); |
| ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]); |
| ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]); |
| ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]); |
| ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]); |
| 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; |
| tree cilist; |
| bool iostat; |
| bool errl; |
| 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 |
| 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. */ |
| |
| switch (format) |
| { |
| case FFESTV_formatNONE: /* no FMT= */ |
| ffeste_io_driver_ = ffeste_io_douio_; |
| if (rec) |
| start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE; |
| #if 0 |
| else if (key) |
| start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE; |
| #endif |
| else |
| start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE; |
| break; |
| |
| case FFESTV_formatLABEL: /* FMT=10 */ |
| case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ |
| case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ |
| ffeste_io_driver_ = ffeste_io_dofio_; |
| if (rec) |
| start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE; |
| #if 0 |
| else if (key) |
| start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE; |
| #endif |
| else if (unit == FFESTV_unitCHAREXPR) |
| start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI; |
| else |
| start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE; |
| break; |
| |
| case FFESTV_formatASTERISK: /* FMT=* */ |
| ffeste_io_driver_ = ffeste_io_dolio_; |
| if (unit == FFESTV_unitCHAREXPR) |
| start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI; |
| else |
| start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE; |
| break; |
| |
| case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST |
| /FOO/] */ |
| ffeste_io_driver_ = NULL; /* No start or driver function. */ |
| start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt; |
| break; |
| |
| default: |
| assert ("Weird stuff" == NULL); |
| start = FFECOM_gfrt, end = FFECOM_gfrt; |
| break; |
| } |
| ffeste_io_endgfrt_ = end; |
| |
| iostat = specified (FFESTP_readixIOSTAT); |
| errl = specified (FFESTP_readixERR); |
| endl = specified (FFESTP_readixEND); |
| |
| ffecom_push_calltemps (); |
| |
| 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 (errl) |
| { /* ERR= */ |
| ffeste_io_err_ |
| = ffecom_lookup_label |
| (info->read_spec[FFESTP_readixERR].u.label); |
| |
| if (endl) |
| { /* ERR= END= */ |
| ffeste_io_end_ |
| = 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= */ |
| ffeste_io_end_ = NULL_TREE; |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = ffeste_io_err_; |
| } |
| } |
| else |
| { /* no ERR= */ |
| ffeste_io_err_ = NULL_TREE; |
| if (endl) |
| { /* END= but no ERR= */ |
| ffeste_io_end_ |
| = 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= */ |
| ffeste_io_end_ = NULL_TREE; |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| 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 */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, ERR=, or END= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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)); |
| } |
| |
| #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. */ |
| |
| void |
| ffeste_R909_item (ffebld expr, ffelexToken expr_token) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| if (expr == NULL) |
| return; |
| 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)! */ |
| 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 (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R909_finish -- READ statement list complete |
| |
| ffeste_R909_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_R909_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| |
| /* Don't generate "if (iostat != 0) goto label;" if label is temp abort |
| label, since we're gonna fall through to there anyway. */ |
| |
| { |
| if (ffeste_io_endgfrt_ != FFECOM_gfrt) |
| ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE), |
| !ffeste_io_abort_is_temp_); |
| |
| clear_momentary (); |
| pop_momentary (); |
| |
| /* If we've got a temp label, generate its code here and have it fan out |
| to the END= or ERR= label as appropriate. */ |
| |
| if (ffeste_io_abort_is_temp_) |
| { |
| DECL_INITIAL (ffeste_io_abort_) = error_mark_node; |
| emit_nop (); |
| expand_label (ffeste_io_abort_); |
| |
| /* if (iostat<0) goto end_label; */ |
| |
| if ((ffeste_io_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 we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| clear_momentary (); |
| } |
| #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. */ |
| |
| void |
| ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit, |
| ffestvFormat format, bool rec) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatNONE: |
| if (rec) |
| fputs ("+ WRITE_ufdac (", dmpout); |
| else |
| fputs ("+ WRITE_ufseq_or_idx (", dmpout); |
| break; |
| |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| if (rec) |
| fputs ("+ WRITE_fmdac (", dmpout); |
| else if (unit == FFESTV_unitCHAREXPR) |
| fputs ("+ WRITE_fmint (", dmpout); |
| else |
| fputs ("+ WRITE_fmseq_or_idx (", dmpout); |
| break; |
| |
| case FFESTV_formatASTERISK: |
| if (unit == FFESTV_unitCHAREXPR) |
| fputs ("+ WRITE_lsint (", dmpout); |
| else |
| fputs ("+ WRITE_lsseq (", dmpout); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| fputs ("+ WRITE_nlseq (", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in R910 WRITE" == NULL); |
| } |
| |
| ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]); |
| ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]); |
| ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]); |
| ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]); |
| ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]); |
| ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]); |
| 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; |
| tree cilist; |
| bool iostat; |
| 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 |
| 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. */ |
| |
| switch (format) |
| { |
| case FFESTV_formatNONE: /* no FMT= */ |
| ffeste_io_driver_ = ffeste_io_douio_; |
| if (rec) |
| start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE; |
| else |
| start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE; |
| break; |
| |
| case FFESTV_formatLABEL: /* FMT=10 */ |
| case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ |
| case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ |
| ffeste_io_driver_ = ffeste_io_dofio_; |
| if (rec) |
| start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE; |
| else if (unit == FFESTV_unitCHAREXPR) |
| start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI; |
| else |
| start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE; |
| break; |
| |
| case FFESTV_formatASTERISK: /* FMT=* */ |
| ffeste_io_driver_ = ffeste_io_dolio_; |
| if (unit == FFESTV_unitCHAREXPR) |
| start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI; |
| else |
| start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE; |
| break; |
| |
| case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST |
| /FOO/] */ |
| ffeste_io_driver_ = NULL; /* No start or driver function. */ |
| start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt; |
| break; |
| |
| default: |
| assert ("Weird stuff" == NULL); |
| start = FFECOM_gfrt, end = FFECOM_gfrt; |
| break; |
| } |
| ffeste_io_endgfrt_ = end; |
| |
| iostat = specified (FFESTP_writeixIOSTAT); |
| errl = specified (FFESTP_writeixERR); |
| |
| ffecom_push_calltemps (); |
| |
| 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_io_end_ = NULL_TREE; |
| |
| if (errl) |
| { /* ERR= */ |
| ffeste_io_err_ |
| = ffeste_io_abort_ |
| = ffecom_lookup_label |
| (info->write_spec[FFESTP_writeixERR].u.label); |
| ffeste_io_abort_is_temp_ = FALSE; |
| } |
| else |
| { /* no ERR= */ |
| ffeste_io_err_ = NULL_TREE; |
| |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| 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= */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, or ERR= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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)); |
| } |
| |
| #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. */ |
| |
| void |
| ffeste_R910_item (ffebld expr, ffelexToken expr_token) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #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 (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R910_finish -- WRITE statement list complete |
| |
| ffeste_R910_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_R910_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| |
| /* 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 we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| clear_momentary (); |
| } |
| #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. */ |
| |
| void |
| ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| fputs ("+ PRINT_fm ", dmpout); |
| break; |
| |
| case FFESTV_formatASTERISK: |
| fputs ("+ PRINT_ls ", dmpout); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| fputs ("+ PRINT_nl ", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in R911 PRINT" == NULL); |
| } |
| ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]); |
| fputc (' ', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| |
| 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 |
| 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. */ |
| |
| switch (format) |
| { |
| case FFESTV_formatLABEL: /* FMT=10 */ |
| case FFESTV_formatCHAREXPR: /* FMT='(I10)' */ |
| case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */ |
| ffeste_io_driver_ = ffeste_io_dofio_; |
| start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE; |
| break; |
| |
| case FFESTV_formatASTERISK: /* FMT=* */ |
| ffeste_io_driver_ = ffeste_io_dolio_; |
| start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE; |
| break; |
| |
| case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST |
| /FOO/] */ |
| ffeste_io_driver_ = NULL; /* No start or driver function. */ |
| start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt; |
| break; |
| |
| default: |
| assert ("Weird stuff" == NULL); |
| start = FFECOM_gfrt, end = FFECOM_gfrt; |
| break; |
| } |
| 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_io_end_ = NULL_TREE; |
| ffeste_io_err_ = NULL_TREE; |
| ffeste_io_abort_ = NULL_TREE; |
| ffeste_io_abort_is_temp_ = FALSE; |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| |
| /* 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)); |
| } |
| |
| push_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R911_item -- PRINT statement i/o item |
| |
| ffeste_R911_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_R911_item (ffebld expr, ffelexToken expr_token) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #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 (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R911_finish -- PRINT statement list complete |
| |
| ffeste_R911_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_R911_finish () |
| { |
| ffeste_check_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 (); |
| |
| clear_momentary (); |
| pop_momentary (); |
| clear_momentary (); |
| } |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R919 -- BACKSPACE statement |
| |
| ffeste_R919(); |
| |
| Make sure a BACKSPACE is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_R919 (ffestpBeruStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ BACKSPACE (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); |
| ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_subr_beru_ (info, FFECOM_gfrtFBACK); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R920 -- ENDFILE statement |
| |
| ffeste_R920(); |
| |
| Make sure a ENDFILE is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_R920 (ffestpBeruStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ ENDFILE (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); |
| ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_subr_beru_ (info, FFECOM_gfrtFEND); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R921 -- REWIND statement |
| |
| ffeste_R921(); |
| |
| Make sure a REWIND is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_R921 (ffestpBeruStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ REWIND (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); |
| ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| ffeste_subr_beru_ (info, FFECOM_gfrtFREW); |
| #else |
| #error |
| #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. */ |
| |
| void |
| ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if (by_file) |
| { |
| fputs ("+ INQUIRE_file (", dmpout); |
| ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]); |
| } |
| else |
| { |
| fputs ("+ INQUIRE_unit (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]); |
| } |
| ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]); |
| ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]); |
| ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]); |
| ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]); |
| ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]); |
| ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]); |
| ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]); |
| ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]); |
| ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]); |
| ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]); |
| ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]); |
| ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]); |
| ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]); |
| ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]); |
| ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]); |
| ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]); |
| ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]); |
| ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]); |
| ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]); |
| ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]); |
| ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]); |
| ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]); |
| ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]); |
| ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]); |
| ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]); |
| ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]); |
| ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]); |
| ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree args; |
| bool iostat; |
| bool errl; |
| |
| #define specified(something) (info->inquire_spec[something].kw_or_val_present) |
| |
| ffeste_emit_line_note_ (); |
| |
| 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]); |
| |
| if (errl) |
| { |
| ffeste_io_err_ |
| = ffeste_io_abort_ |
| = ffecom_lookup_label |
| (info->inquire_spec[FFESTP_inquireixERR].u.label); |
| ffeste_io_abort_is_temp_ = FALSE; |
| } |
| else |
| { |
| ffeste_io_err_ = NULL_TREE; |
| |
| if ((ffeste_io_abort_is_temp_ = iostat)) |
| ffeste_io_abort_ = ffecom_temp_label (); |
| else |
| ffeste_io_abort_ = NULL_TREE; |
| } |
| |
| if (iostat) |
| { /* IOSTAT= */ |
| 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= */ |
| ffeste_io_iostat_is_temp_ = TRUE; |
| ffeste_io_iostat_ |
| = ffecom_push_tempvar (ffecom_integer_type_node, |
| FFETARGET_charactersizeNONE, -1, FALSE); |
| } |
| else |
| { /* no IOSTAT=, or ERR= */ |
| ffeste_io_iostat_is_temp_ = FALSE; |
| ffeste_io_iostat_ = NULL_TREE; |
| } |
| |
| /* 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_); |
| |
| /* If we've got a temp label, generate its code here. */ |
| |
| if (ffeste_io_abort_is_temp_) |
| { |
| DECL_INITIAL (ffeste_io_abort_) = error_mark_node; |
| emit_nop (); |
| expand_label (ffeste_io_abort_); |
| |
| assert (ffeste_io_err_ == NULL_TREE); |
| } |
| |
| /* If we've got a temp iostat, pop the temp. */ |
| |
| if (ffeste_io_iostat_is_temp_) |
| ffecom_pop_tempvar (ffeste_io_iostat_); |
| |
| ffecom_pop_calltemps (); |
| |
| #undef specified |
| } |
| |
| 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. */ |
| |
| void |
| ffeste_R923B_start (ffestpInquireStmt *info UNUSED) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ INQUIRE (", dmpout); |
| ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]); |
| fputs (") ", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL); |
| ffeste_emit_line_note_ (); |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R923B_item -- INQUIRE statement i/o item |
| |
| ffeste_R923B_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_R923B_item (ffebld expr UNUSED) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| 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. */ |
| |
| void |
| ffeste_R923B_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| clear_momentary (); |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1001 -- FORMAT statement |
| |
| ffeste_R1001(format_list); */ |
| |
| void |
| ffeste_R1001 (ffests s) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s)); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree t; |
| tree ttype; |
| tree maxindex; |
| tree var; |
| |
| assert (ffeste_label_formatdef_ != NULL); |
| |
| ffeste_emit_line_note_ (); |
| |
| t = build_string (ffests_length (s), ffests_text (s)); |
| |
| TREE_TYPE (t) |
| = build_type_variant (build_array_type |
| (char_type_node, |
| build_range_type (integer_type_node, |
| integer_one_node, |
| build_int_2 (ffests_length (s), |
| 0))), |
| 1, 0); |
| TREE_CONSTANT (t) = 1; |
| TREE_STATIC (t) = 1; |
| |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| |
| var = ffecom_lookup_label (ffeste_label_formatdef_); |
| if ((var != NULL_TREE) |
| && (TREE_CODE (var) == VAR_DECL)) |
| { |
| DECL_INITIAL (var) = t; |
| maxindex = build_int_2 (ffests_length (s) - 1, 0); |
| ttype = TREE_TYPE (var); |
| TYPE_DOMAIN (ttype) = build_range_type (integer_type_node, |
| integer_zero_node, |
| maxindex); |
| if (!TREE_TYPE (maxindex)) |
| TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype); |
| layout_type (ttype); |
| rest_of_decl_compilation (var, NULL, 1, 0); |
| expand_decl (var); |
| expand_decl_init (var); |
| } |
| |
| resume_temporary_allocation (); |
| pop_obstacks (); |
| |
| ffeste_label_formatdef_ = NULL; |
| } |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1103 -- End a PROGRAM |
| |
| ffeste_R1103(); */ |
| |
| void |
| ffeste_R1103 () |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ END_PROGRAM\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1112 -- End a BLOCK DATA |
| |
| ffeste_R1112(TRUE); */ |
| |
| void |
| ffeste_R1112 () |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("* END_BLOCK_DATA\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1212 -- CALL statement |
| |
| ffeste_R1212(expr,expr_token); |
| |
| Make sure statement is valid here; implement. */ |
| |
| void |
| ffeste_R1212 (ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ CALL ", dmpout); |
| ffebld_dump (expr); |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| ffebld args = ffebld_right (expr); |
| ffebld arg; |
| ffebld labels = NULL; /* First in list of LABTERs. */ |
| ffebld prevlabels = NULL; |
| ffebld prevargs = NULL; |
| |
| ffeste_emit_line_note_ (); |
| |
| /* Here we split the list at ffebld_right(expr) into two lists: one at |
| ffebld_right(expr) consisting of all items that are not LABTERs, the |
| other at labels consisting of all items that are LABTERs. Then, if |
| the latter list is NULL, we have an ordinary call, else we have a call |
| with alternate returns. */ |
| |
| for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args)) |
| { |
| if (((arg = ffebld_head (args)) == NULL) |
| || (ffebld_op (arg) != FFEBLD_opLABTER)) |
| { |
| if (prevargs == NULL) |
| { |
| prevargs = args; |
| ffebld_set_right (expr, args); |
| } |
| else |
| { |
| ffebld_set_trail (prevargs, args); |
| prevargs = args; |
| } |
| } |
| else |
| { |
| if (prevlabels == NULL) |
| { |
| prevlabels = labels = args; |
| } |
| else |
| { |
| ffebld_set_trail (prevlabels, args); |
| prevlabels = args; |
| } |
| } |
| } |
| if (prevlabels == NULL) |
| labels = NULL; |
| else |
| ffebld_set_trail (prevlabels, NULL); |
| if (prevargs == NULL) |
| ffebld_set_right (expr, NULL); |
| else |
| ffebld_set_trail (prevargs, NULL); |
| |
| if (labels == NULL) |
| expand_expr_stmt (ffecom_expr (expr)); |
| else |
| { |
| tree texpr; |
| tree value; |
| tree tlabel; |
| int caseno; |
| int pushok; |
| tree duplicate; |
| |
| 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)) |
| { |
| 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))); |
| 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 (); |
| } |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1221 -- End a FUNCTION |
| |
| ffeste_R1221(TRUE); */ |
| |
| void |
| ffeste_R1221 () |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ END_FUNCTION\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_R1225 -- End a SUBROUTINE |
| |
| ffeste_R1225(TRUE); */ |
| |
| void |
| ffeste_R1225 () |
| { |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "+ END_SUBROUTINE\n"); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #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. */ |
| |
| void |
| ffeste_R1226 (ffesymbol entry) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry)); |
| if (ffesymbol_dummyargs (entry) != NULL) |
| { |
| ffebld argh; |
| |
| fputc ('(', dmpout); |
| for (argh = ffesymbol_dummyargs (entry); |
| argh != NULL; |
| argh = ffebld_trail (argh)) |
| { |
| assert (ffebld_head (argh) != NULL); |
| switch (ffebld_op (ffebld_head (argh))) |
| { |
| case FFEBLD_opSYMTER: |
| fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))), |
| dmpout); |
| break; |
| |
| case FFEBLD_opSTAR: |
| fputc ('*', dmpout); |
| break; |
| |
| default: |
| fputc ('?', dmpout); |
| ffebld_dump (ffebld_head (argh)); |
| fputc ('?', dmpout); |
| break; |
| } |
| if (ffebld_trail (argh) != NULL) |
| fputc (',', dmpout); |
| } |
| fputc (')', dmpout); |
| } |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree label = ffesymbol_hook (entry).length_tree; |
| |
| ffeste_emit_line_note_ (); |
| |
| 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. */ |
| |
| void |
| ffeste_R1227 (ffestw block UNUSED, ffebld expr) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| if (expr == NULL) |
| { |
| fputs ("+ RETURN\n", dmpout); |
| } |
| else |
| { |
| fputs ("+ RETURN_alternate ", dmpout); |
| ffebld_dump (expr); |
| fputc ('\n', dmpout); |
| } |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| { |
| tree rtn; |
| |
| ffeste_emit_line_note_ (); |
| ffecom_push_calltemps (); |
| |
| rtn = ffecom_return_expr (expr); |
| |
| if ((rtn == NULL_TREE) |
| || (rtn == error_mark_node)) |
| expand_null_return (); |
| else |
| { |
| tree result = DECL_RESULT (current_function_decl); |
| |
| if ((result != error_mark_node) |
| && (TREE_TYPE (result) != error_mark_node)) |
| expand_return (ffecom_modify (NULL_TREE, |
| result, |
| convert (TREE_TYPE (result), |
| rtn))); |
| else |
| expand_null_return (); |
| } |
| |
| ffecom_pop_calltemps (); |
| clear_momentary (); |
| } |
| #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. */ |
| |
| #if FFESTR_VXT |
| void |
| ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatNONE: |
| fputs ("+ REWRITE_uf (", dmpout); |
| break; |
| |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| fputs ("+ REWRITE_fm (", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in V018 REWRITE" == NULL); |
| } |
| ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]); |
| ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]); |
| ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]); |
| fputs (") ", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V018_item -- REWRITE statement i/o item |
| |
| ffeste_V018_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_V018_item (ffebld expr) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V018_finish -- REWRITE statement list complete |
| |
| ffeste_V018_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V018_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V019_start -- ACCEPT statement list begin |
| |
| ffeste_V019_start(); |
| |
| Verify that ACCEPT is valid here, and begin accepting items in the |
| list. */ |
| |
| void |
| ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| fputs ("+ ACCEPT_fm ", dmpout); |
| break; |
| |
| case FFESTV_formatASTERISK: |
| fputs ("+ ACCEPT_ls ", dmpout); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| fputs ("+ ACCEPT_nl ", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in V019 ACCEPT" == NULL); |
| } |
| ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]); |
| fputc (' ', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V019_item -- ACCEPT statement i/o item |
| |
| ffeste_V019_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_V019_item (ffebld expr) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V019_finish -- ACCEPT statement list complete |
| |
| ffeste_V019_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V019_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| #endif |
| /* ffeste_V020_start -- TYPE statement list begin |
| |
| ffeste_V020_start(); |
| |
| Verify that TYPE is valid here, and begin accepting items in the |
| list. */ |
| |
| void |
| ffeste_V020_start (ffestpTypeStmt *info UNUSED, |
| ffestvFormat format UNUSED) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| switch (format) |
| { |
| case FFESTV_formatLABEL: |
| case FFESTV_formatCHAREXPR: |
| case FFESTV_formatINTEXPR: |
| fputs ("+ TYPE_fm ", dmpout); |
| break; |
| |
| case FFESTV_formatASTERISK: |
| fputs ("+ TYPE_ls ", dmpout); |
| break; |
| |
| case FFESTV_formatNAMELIST: |
| fputs ("* TYPE_nl ", dmpout); |
| break; |
| |
| default: |
| assert ("Unexpected kind of format item in V020 TYPE" == NULL); |
| } |
| ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]); |
| fputc (' ', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V020_item -- TYPE statement i/o item |
| |
| ffeste_V020_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_V020_item (ffebld expr UNUSED) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V020_finish -- TYPE statement list complete |
| |
| ffeste_V020_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V020_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V021 -- DELETE statement |
| |
| ffeste_V021(); |
| |
| Make sure a DELETE is valid in the current context, and implement it. */ |
| |
| #if FFESTR_VXT |
| void |
| ffeste_V021 (ffestpDeleteStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ DELETE (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]); |
| ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]); |
| ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V022 -- UNLOCK statement |
| |
| ffeste_V022(); |
| |
| Make sure a UNLOCK is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_V022 (ffestpBeruStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ UNLOCK (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]); |
| ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V023_start -- ENCODE(...) statement list begin |
| |
| ffeste_V023_start(); |
| |
| Verify that ENCODE is valid here, and begin accepting items in the |
| list. */ |
| |
| void |
| ffeste_V023_start (ffestpVxtcodeStmt *info) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ ENCODE (", dmpout); |
| ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]); |
| ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]); |
| ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]); |
| ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]); |
| fputs (") ", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V023_item -- ENCODE statement i/o item |
| |
| ffeste_V023_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_V023_item (ffebld expr) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V023_finish -- ENCODE statement list complete |
| |
| ffeste_V023_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V023_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V024_start -- DECODE(...) statement list begin |
| |
| ffeste_V024_start(); |
| |
| Verify that DECODE is valid here, and begin accepting items in the |
| list. */ |
| |
| void |
| ffeste_V024_start (ffestpVxtcodeStmt *info) |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ DECODE (", dmpout); |
| ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]); |
| ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]); |
| ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]); |
| ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]); |
| fputs (") ", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V024_item -- DECODE statement i/o item |
| |
| ffeste_V024_item(expr,expr_token); |
| |
| Implement output-list expression. */ |
| |
| void |
| ffeste_V024_item (ffebld expr) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (expr); |
| fputc (',', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V024_finish -- DECODE statement list complete |
| |
| ffeste_V024_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V024_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V025_start -- DEFINEFILE statement list begin |
| |
| ffeste_V025_start(); |
| |
| Verify that DEFINEFILE is valid here, and begin accepting items in the |
| list. */ |
| |
| void |
| ffeste_V025_start () |
| { |
| ffeste_check_start_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ DEFINE_FILE ", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V025_item -- DEFINE FILE statement item |
| |
| ffeste_V025_item(u,ut,m,mt,n,nt,asv,asvt); |
| |
| Implement item. */ |
| |
| void |
| ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv) |
| { |
| ffeste_check_item_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| ffebld_dump (u); |
| fputc ('(', dmpout); |
| ffebld_dump (m); |
| fputc (',', dmpout); |
| ffebld_dump (n); |
| fputs (",U,", dmpout); |
| ffebld_dump (asv); |
| fputs ("),", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V025_finish -- DEFINE FILE statement list complete |
| |
| ffeste_V025_finish(); |
| |
| Just wrap up any local activities. */ |
| |
| void |
| ffeste_V025_finish () |
| { |
| ffeste_check_finish_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputc ('\n', dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| /* ffeste_V026 -- FIND statement |
| |
| ffeste_V026(); |
| |
| Make sure a FIND is valid in the current context, and implement it. */ |
| |
| void |
| ffeste_V026 (ffestpFindStmt *info) |
| { |
| ffeste_check_simple_ (); |
| |
| #if FFECOM_targetCURRENT == FFECOM_targetFFE |
| fputs ("+ FIND (", dmpout); |
| ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]); |
| ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]); |
| ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]); |
| ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]); |
| fputs (")\n", dmpout); |
| #elif FFECOM_targetCURRENT == FFECOM_targetGCC |
| #else |
| #error |
| #endif |
| } |
| |
| #endif |