home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / ste.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  146KB  |  5,389 lines
  1. /* ste.c -- Implementation File (module.c template V1.0)
  2.    Copyright (C) 1995 Free Software Foundation, Inc.
  3.    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
  4.  
  5. This file is part of GNU Fortran.
  6.  
  7. GNU Fortran is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2, or (at your option)
  10. any later version.
  11.  
  12. GNU Fortran is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. GNU General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with GNU Fortran; see the file COPYING.  If not, write to
  19. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.    Related Modules:
  22.       ste.c
  23.  
  24.    Description:
  25.       Implements the various statements and such like.
  26.  
  27.    Modifications:
  28. */
  29.  
  30. /* As of 0.5.4, any statement that calls on ffecom to transform an
  31.    expression might need to be wrapped in ffecom_push_calltemps ()
  32.    and ffecom_pop_calltemps () as are some other cases.  That is
  33.    the case when the transformation might involve generation of
  34.    a temporary that must be auto-popped, the specific case being
  35.    when a COMPLEX operation requiring a call to libf2c being
  36.    generated, whereby a temp is needed to hold the result since
  37.    libf2c doesn't return COMPLEX results directly.  Cases where it
  38.    is known that ffecom_expr () won't need to do this, such as
  39.    the CALL statement (where it's the transformation of the
  40.    call expr itself that does the wrapping), don't need to bother
  41.    with this wrapping.  Forgetting to do the wrapping currently
  42.    means a crash at an assertion when the wrapping would be helpful
  43.    to keep temporaries from being wasted -- see ffecom_push_tempvar.  */
  44.  
  45. /* Include files. */
  46.  
  47. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  48. #include "config.j"
  49. #include "rtl.j"
  50. #endif
  51.  
  52. #include "proj.h"
  53. #include "ste.h"
  54. #include "bld.h"
  55. #include "com.h"
  56. #include "lab.h"
  57. #include "lex.h"
  58. #include "sta.h"
  59. #include "stp.h"
  60. #include "str.h"
  61. #include "sts.h"
  62. #include "stt.h"
  63. #include "stv.h"
  64. #include "stw.h"
  65. #include "symbol.h"
  66.  
  67. /* Externals defined here. */
  68.  
  69.  
  70. /* Simple definitions and enumerations. */
  71.  
  72. typedef enum
  73.   {
  74.     FFESTE_stateletSIMPLE_,    /* Expecting simple/start. */
  75.     FFESTE_stateletATTRIB_,    /* Expecting attrib/item/itemstart. */
  76.     FFESTE_stateletITEM_,    /* Expecting item/itemstart/finish. */
  77.     FFESTE_stateletITEMVALS_,    /* Expecting itemvalue/itemendvals. */
  78.     FFESTE_
  79.   } ffesteStatelet_;
  80.  
  81. /* Internal typedefs. */
  82.  
  83.  
  84. /* Private include files. */
  85.  
  86.  
  87. /* Internal structure definitions. */
  88.  
  89.  
  90. /* Static objects accessed by functions in this module. */
  91.  
  92. static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
  93. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  94. static ffelab ffeste_label_formatdef_ = NULL;
  95. static tree (*ffeste_io_driver_) (ffebld expr);    /* do?io. */
  96. static ffecomGfrt ffeste_io_endgfrt_;    /* end function to call. */
  97. static tree ffeste_io_abort_;    /* abort-io label or NULL_TREE. */
  98. static bool ffeste_io_abort_is_temp_;    /* abort-io label is a temp. */
  99. static tree ffeste_io_end_;    /* END= label or NULL_TREE. */
  100. static tree ffeste_io_err_;    /* ERR= label or NULL_TREE. */
  101. static tree ffeste_io_iostat_;    /* IOSTAT= var or NULL_TREE. */
  102. static bool ffeste_io_iostat_is_temp_;    /* IOSTAT= var is a temp. */
  103. #endif
  104.  
  105. /* Static functions (internal). */
  106.  
  107. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  108. static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
  109.                   tree *xitersvar, ffebld var,
  110.                   ffebld start, ffelexToken start_token,
  111.                   ffebld end, ffelexToken end_token,
  112.                   ffebld incr, ffelexToken incr_token,
  113.                   char *msg);
  114. static void ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar);
  115. static void ffeste_io_call_ (tree call, bool do_check);
  116. static tree ffeste_io_dofio_ (ffebld expr);
  117. static tree ffeste_io_dolio_ (ffebld expr);
  118. static tree ffeste_io_douio_ (ffebld expr);
  119. static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
  120.                    ffebld unit_expr, int unit_dflt);
  121. static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
  122.                    ffebld unit_expr, int unit_dflt,
  123.                    bool have_end, ffestvFormat format,
  124.                    ffestpFile *format_spec, bool rec,
  125.                    ffebld rec_expr);
  126. static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
  127.                    ffestpFile *stat_spec);
  128. static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
  129.                 bool have_end, ffestvFormat format,
  130.                 ffestpFile *format_spec);
  131. static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
  132. static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
  133.                   ffestpFile *file_spec,
  134.                   ffestpFile *stat_spec,
  135.                   ffestpFile *access_spec,
  136.                   ffestpFile *form_spec,
  137.                   ffestpFile *recl_spec,
  138.                   ffestpFile *blank_spec);
  139. static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
  140. #endif
  141. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  142. static void ffeste_subr_file_ (char *kw, ffestpFile *spec);
  143. #endif
  144.  
  145. /* Internal macros. */
  146.  
  147. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  148. #define ffeste_emit_line_note_() \
  149.   emit_line_note (input_filename, lineno)
  150. #endif
  151. #define ffeste_check_simple_() \
  152.   assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
  153. #define ffeste_check_start_() \
  154.   assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
  155.   ffeste_statelet_ = FFESTE_stateletATTRIB_
  156. #define ffeste_check_attrib_() \
  157.   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
  158. #define ffeste_check_item_() \
  159.   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_     \
  160.      || ffeste_statelet_ == FFESTE_stateletITEM_); \
  161.   ffeste_statelet_ = FFESTE_stateletITEM_
  162. #define ffeste_check_item_startvals_() \
  163.   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_     \
  164.      || ffeste_statelet_ == FFESTE_stateletITEM_); \
  165.   ffeste_statelet_ = FFESTE_stateletITEMVALS_
  166. #define ffeste_check_item_value_() \
  167.   assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
  168. #define ffeste_check_item_endvals_() \
  169.   assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
  170.   ffeste_statelet_ = FFESTE_stateletITEM_
  171. #define ffeste_check_finish_() \
  172.   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_     \
  173.      || ffeste_statelet_ == FFESTE_stateletITEM_); \
  174.   ffeste_statelet_ = FFESTE_stateletSIMPLE_
  175.  
  176. #define ffeste_f2c_charnolenspec_(Spec,Exp,Init)                \
  177.   do                                          \
  178.     {                                          \
  179.     if (Spec->kw_or_val_present)                          \
  180.     Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&ignore);         \
  181.       else                                      \
  182.     Exp = null_pointer_node;                          \
  183.     if (TREE_CONSTANT(Exp))                              \
  184.     {                                      \
  185.     Init = Exp;                                  \
  186.     Exp = NULL_TREE;                              \
  187.     }                                      \
  188.       else                                      \
  189.     {                                      \
  190.     Init = null_pointer_node;                          \
  191.     constantp = FALSE;                              \
  192.     }                                      \
  193.     } while(0)
  194.  
  195. #define ffeste_f2c_charspec_(Spec,Exp,Init,Lenexp,Leninit)            \
  196.   do                                          \
  197.     {                                          \
  198.     if (Spec->kw_or_val_present)                          \
  199.     Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&Lenexp);              \
  200.       else                                      \
  201.     {                                      \
  202.     Exp = null_pointer_node;                          \
  203.     Lenexp = ffecom_f2c_ftnlen_zero_node;                      \
  204.     }                                      \
  205.     if (TREE_CONSTANT(Exp))                              \
  206.     {                                      \
  207.     Init = Exp;                                  \
  208.     Exp = NULL_TREE;                              \
  209.     }                                      \
  210.       else                                      \
  211.     {                                      \
  212.     Init = null_pointer_node;                          \
  213.     constantp = FALSE;                              \
  214.     }                                      \
  215.     if ((Lenexp != NULL_TREE) && TREE_CONSTANT(Lenexp))                  \
  216.     {                                      \
  217.     Leninit = Lenexp;                              \
  218.     Lenexp = NULL_TREE;                              \
  219.     }                                      \
  220.       else                                      \
  221.     {                                      \
  222.     Leninit = ffecom_f2c_ftnlen_zero_node;                      \
  223.     constantp = FALSE;                              \
  224.     }                                      \
  225.     } while(0)
  226.  
  227. #define ffeste_f2c_exp_(Field,Exp)                          \
  228.   do                                          \
  229.     {                                          \
  230.     if (Exp != NULL_TREE)                              \
  231.     {                                      \
  232.     Exp = ffecom_modify(void_type_node,ffecom_2(COMPONENT_REF,          \
  233.           TREE_TYPE(Field),t,Field),Exp);                      \
  234.     expand_expr_stmt(Exp);                              \
  235.     }                                      \
  236.     } while(0)
  237.  
  238. #define ffeste_f2c_init_(Init)                            \
  239.   do                                          \
  240.     {                                          \
  241.     TREE_CHAIN(initn) = build_tree_list((field = TREE_CHAIN(field)),Init);    \
  242.     initn = TREE_CHAIN(initn);                              \
  243.     } while(0)
  244.  
  245. #define ffeste_f2c_flagspec_(Flag,Init)                          \
  246.   do { Init = convert (ffecom_f2c_flag_type_node,                  \
  247.                Flag ? integer_one_node : integer_zero_node); }          \
  248.     while(0)
  249.  
  250. #define ffeste_f2c_intspec_(Spec,Exp,Init)                      \
  251.   do                                          \
  252.     {                                          \
  253.     if (Spec->kw_or_val_present)                          \
  254.     Exp = ffecom_expr(Spec->u.expr);                      \
  255.       else                                      \
  256.     Exp = ffecom_integer_zero_node;                          \
  257.     if (TREE_CONSTANT(Exp))                              \
  258.     {                                      \
  259.     Init = Exp;                                  \
  260.     Exp = NULL_TREE;                              \
  261.     }                                      \
  262.       else                                      \
  263.     {                                      \
  264.     Init = ffecom_integer_zero_node;                      \
  265.     constantp = FALSE;                              \
  266.     }                                      \
  267.     } while(0)
  268.  
  269. #define ffeste_f2c_ptrtointspec_(Spec,Exp,Init)                    \
  270.   do                                          \
  271.     {                                          \
  272.     if (Spec->kw_or_val_present)                          \
  273.     Exp = ffecom_ptr_to_expr(Spec->u.expr);                 \
  274.       else                                      \
  275.     Exp = null_pointer_node;                          \
  276.     if (TREE_CONSTANT(Exp))                              \
  277.     {                                      \
  278.     Init = Exp;                                  \
  279.     Exp = NULL_TREE;                              \
  280.     }                                      \
  281.       else                                      \
  282.     {                                      \
  283.     Init = null_pointer_node;                          \
  284.     constantp = FALSE;                              \
  285.     }                                      \
  286.     } while(0)
  287.  
  288.  
  289. /* Begin an iterative DO loop.  Pass the block to start if applicable.
  290.  
  291.    NOTE: Does _two_ push_momentary () calls, which the caller must
  292.    undo (by calling ffeste_end_iterdo_).  */
  293.  
  294. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  295. static void
  296. ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
  297.               tree *xitersvar, ffebld var,
  298.               ffebld start, ffelexToken start_token,
  299.               ffebld end, ffelexToken end_token,
  300.               ffebld incr, ffelexToken incr_token,
  301.               char *msg)
  302. {
  303.   tree tvar;
  304.   tree expr;
  305.   tree tstart;
  306.   tree tend;
  307.   tree tincr;
  308.   tree tincr_saved;
  309.   tree niters;
  310.  
  311.   push_momentary ();        /* Want to save these throughout the loop. */
  312.  
  313.   tvar = ffecom_expr_rw (var);
  314.   tincr = ffecom_expr (incr);
  315.  
  316.   /* Check whether incr is known to be zero, complain and fix.  */
  317.  
  318.   if (integer_zerop (tincr) || real_zerop (tincr))
  319.     {
  320.       ffebad_start (FFEBAD_DO_STEP_ZERO);
  321.       ffebad_here (0, ffelex_token_where_line (incr_token),
  322.            ffelex_token_where_column (incr_token));
  323.       ffebad_string (msg);
  324.       ffebad_finish ();
  325.       tincr = convert (TREE_TYPE (tvar), integer_one_node);
  326.     }
  327.  
  328.   tincr_saved = ffecom_save_tree (tincr);
  329.  
  330.   push_momentary ();        /* Want to discard the rest after the loop. */
  331.  
  332.   tstart = ffecom_expr (start);
  333.   tend = ffecom_expr (end);
  334.  
  335.   {                /* For warnings only, nothing else
  336.                    happens here.  */
  337.     tree try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
  338.              tend,
  339.              tstart);
  340.  
  341.     try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
  342.              try,
  343.             tincr);
  344.  
  345.     if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
  346.       try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
  347.               tincr);
  348.     else
  349.       try = convert (integer_type_node,
  350.              ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
  351.                    try,
  352.                    tincr));
  353.  
  354.     /* Warn if loop never executed, since we've done the evaluation
  355.        of the unofficial iteration count already.  */
  356.  
  357.     try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
  358.                     try,
  359.                     convert (TREE_TYPE (tvar),
  360.                          integer_zero_node)));
  361.  
  362.     if (integer_onep (try))
  363.       {
  364.     ffebad_start (FFEBAD_DO_NULL);
  365.     ffebad_here (0, ffelex_token_where_line (start_token),
  366.              ffelex_token_where_column (start_token));
  367.     ffebad_string (msg);
  368.     ffebad_finish ();
  369.       }
  370.  
  371.     /* Warn if end plus incr would overflow.  */
  372.  
  373.     try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tend),
  374.             tend,
  375.             tincr);
  376.  
  377.     if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
  378.     && TREE_CONSTANT_OVERFLOW (try))
  379.       {
  380.     ffebad_start (FFEBAD_DO_END_OVERFLOW);
  381.     ffebad_here (0, ffelex_token_where_line (end_token),
  382.              ffelex_token_where_column (end_token));
  383.     ffebad_string (msg);
  384.     ffebad_finish ();
  385.       }
  386.   }
  387.  
  388.   /* Do the initial assignment into the DO var.  */
  389.  
  390.   expr = ffecom_modify (void_type_node, tvar, tstart);
  391.   expand_expr_stmt (expr);
  392.  
  393.   expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
  394.            tend,
  395.            TREE_CONSTANT (tstart) ? tstart : tvar);
  396.  
  397.   expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
  398.            expr,
  399.            convert (TREE_TYPE (expr), tincr_saved));
  400.  
  401.   if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
  402.     expr = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node,
  403.              expr,
  404.              tincr_saved);
  405.   else
  406.     expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
  407.              expr,
  408.              tincr_saved);
  409.  
  410.   if ((TREE_TYPE (tvar) != error_mark_node)
  411.       && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
  412.       || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
  413.           && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
  414.            != INTEGER_CST)
  415.           || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
  416.               <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
  417.     /* Convert unless promoting INTEGER type of any kind downward to
  418.        default INTEGER; else leave as, say, INTEGER*8 (long long int).  */
  419.     expr = convert (ffecom_integer_type_node, expr);
  420.  
  421.   niters = ffecom_push_tempvar (TREE_TYPE (expr),
  422.                 FFETARGET_charactersizeNONE, -1, FALSE);
  423.   expr = ffecom_modify (void_type_node, niters, expr);
  424.   expand_expr_stmt (expr);
  425.  
  426.   if (block == NULL)
  427.     expand_start_loop_continue_elsewhere (0);
  428.   else
  429.     ffestw_set_do_hook (block,
  430.             expand_start_loop_continue_elsewhere (1));
  431.  
  432.   expr = ffecom_truth_value (ffecom_2 (GT_EXPR, integer_type_node,
  433.                        ffecom_2 (POSTDECREMENT_EXPR,
  434.                          ffecom_integer_type_node,
  435.                          niters,
  436.                          ffecom_integer_one_node),
  437.                        ffecom_integer_zero_node));
  438.  
  439.   expand_exit_loop_if_false (0,
  440.                  expr);
  441.  
  442.   clear_momentary ();        /* Discard the above now that we're done with
  443.                    DO stmt. */
  444.  
  445.   if (block == NULL)
  446.     {
  447.       *xtvar = tvar;
  448.       *xtincr = tincr_saved;
  449.       *xitersvar = niters;
  450.     }
  451.   else
  452.     {
  453.       ffestw_set_do_tvar (block, tvar);
  454.       ffestw_set_do_incr_saved (block, tincr_saved);
  455.       ffestw_set_do_count_var (block, niters);
  456.     }
  457. }
  458.  
  459. #endif
  460.  
  461. /* End an iterative DO loop.  Pass the same iteration variable and increment
  462.    value trees that were generated in the paired _begin_ call.  */
  463.  
  464. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  465. static void
  466. ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar)
  467. {
  468.   tree expr;
  469.  
  470.   expand_loop_continue_here ();
  471.   expr = ffecom_modify (void_type_node, tvar,
  472.             ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
  473.                   tvar,
  474.                   tincr));
  475.   expand_expr_stmt (expr);
  476.   expand_end_loop ();
  477.  
  478.   ffecom_pop_tempvar (itersvar);    /* Free #iters var. */
  479.  
  480.   clear_momentary ();
  481.   pop_momentary ();        /* Lose the stuff we just built. */
  482.  
  483.   clear_momentary ();
  484.   pop_momentary ();        /* Lose the tvar and incr_saved trees. */
  485. }
  486.  
  487. #endif
  488. /* ffeste_io_call_ -- Generate call to run-time I/O routine
  489.  
  490.    tree callexpr = build(CALL_EXPR,...);
  491.    ffeste_io_call_(callexpr,TRUE);
  492.  
  493.    Sets TREE_SIDE_EFFECTS(callexpr) = 1.  If ffeste_io_iostat_ is not
  494.    NULL_TREE, replaces callexpr with "iostat = callexpr;".  Expands the
  495.    result.  If ffeste_io_abort_ is not NULL_TREE and the second argument
  496.    is TRUE, generates "if (iostat != 0) goto ffeste_io_abort_;".  */
  497.  
  498. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  499. static void
  500. ffeste_io_call_ (tree call, bool do_check)
  501. {
  502.   /* Generate the call and optional assignment into iostat var. */
  503.  
  504.   TREE_SIDE_EFFECTS (call) = 1;
  505.   if (ffeste_io_iostat_ != NULL_TREE)
  506.     {
  507.       call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
  508.                 ffeste_io_iostat_, call);
  509.     }
  510.   expand_expr_stmt (call);
  511.  
  512.   if (!do_check)
  513.     return;
  514.  
  515.   /* Generate optional test. */
  516.  
  517.   if ((ffeste_io_abort_ != NULL_TREE)
  518.       && (TREE_CODE (ffeste_io_abort_) != ERROR_MARK))
  519.     {
  520.       expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
  521.       expand_goto (ffeste_io_abort_);
  522.       expand_end_cond ();
  523.     }
  524. }
  525.  
  526. #endif
  527. /* ffeste_io_dofio_ -- Generate call to do_fio for formatted I/O item
  528.  
  529.    ffebld expr;
  530.    tree call;
  531.    call = ffeste_io_dofio_(expr);
  532.  
  533.    Returns a tree for a CALL_EXPR to the do_fio function, which handles
  534.    a formatted I/O list item, along with the appropriate arguments for
  535.    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
  536.    for the CALL_EXPR, expand (emit) the expression, emit any assignment
  537.    of the result to an IOSTAT= variable, and emit any checking of the
  538.    result for errors.  */
  539.  
  540. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  541. static tree
  542. ffeste_io_dofio_ (ffebld expr)
  543. {
  544.   tree num_elements;
  545.   tree variable;
  546.   tree size;
  547.   tree arglist;
  548.   ffeinfoBasictype bt;
  549.   ffeinfoKindtype kt;
  550.   bool is_complex;
  551.  
  552.   bt = ffeinfo_basictype (ffebld_info (expr));
  553.   kt = ffeinfo_kindtype (ffebld_info (expr));
  554.  
  555.   if ((bt == FFEINFO_basictypeANY)
  556.       || (kt == FFEINFO_kindtypeANY))
  557.     return error_mark_node;
  558.  
  559.   if (bt == FFEINFO_basictypeCOMPLEX)
  560.     {
  561.       is_complex = TRUE;
  562.       bt = FFEINFO_basictypeREAL;
  563.     }
  564.   else
  565.     is_complex = FALSE;
  566.  
  567.   ffecom_push_calltemps ();
  568.  
  569.   variable = ffecom_arg_ptr_to_expr (expr, &size);
  570.  
  571.   if ((variable == error_mark_node)
  572.       || (size == error_mark_node))
  573.     {
  574.       ffecom_pop_calltemps ();
  575.       return error_mark_node;
  576.     }
  577.  
  578.   if (size == NULL_TREE)    /* Already filled in for CHARACTER type. */
  579.     {                /* "(ftnlen) sizeof(type)" */
  580.       size = size_binop (CEIL_DIV_EXPR,
  581.              TYPE_SIZE (ffecom_tree_type[bt][kt]),
  582.              size_int (TYPE_PRECISION (char_type_node)));
  583. #if 0    /* Assume that while it is possible that char * is wider than
  584.        ftnlen, no object in Fortran space can get big enough for its
  585.        size to be wider than ftnlen.  I really hope nobody wastes
  586.        time debugging a case where it can!  */
  587.       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
  588.           >= TYPE_PRECISION (TREE_TYPE (size)));
  589. #endif
  590.       size = convert (ffecom_f2c_ftnlen_type_node, size);
  591.     }
  592.  
  593.   if ((ffeinfo_rank (ffebld_info (expr)) == 0)
  594.       || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
  595.     num_elements = is_complex ? ffecom_f2c_ftnlen_two_node
  596.       : ffecom_f2c_ftnlen_one_node;
  597.   else
  598.     {
  599.       num_elements = size_binop (CEIL_DIV_EXPR,
  600.             TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
  601.       num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
  602.                  size_int (TYPE_PRECISION
  603.                        (char_type_node)));
  604.       num_elements = convert (ffecom_f2c_ftnlen_type_node,
  605.                   num_elements);
  606.     }
  607.  
  608.   num_elements
  609.     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
  610.         num_elements);
  611.  
  612.   variable = convert (string_type_node, variable);
  613.  
  614.   arglist = build_tree_list (NULL_TREE, num_elements);
  615.   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
  616.   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
  617.  
  618.   ffecom_pop_calltemps ();
  619.  
  620.   return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist);
  621. }
  622.  
  623. #endif
  624. /* ffeste_io_dolio_ -- Generate call to do_lio for list-directed I/O item
  625.  
  626.    ffebld expr;
  627.    tree call;
  628.    call = ffeste_io_dolio_(expr);
  629.  
  630.    Returns a tree for a CALL_EXPR to the do_lio function, which handles
  631.    a list-directed I/O list item, along with the appropriate arguments for
  632.    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
  633.    for the CALL_EXPR, expand (emit) the expression, emit any assignment
  634.    of the result to an IOSTAT= variable, and emit any checking of the
  635.    result for errors.  */
  636.  
  637. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  638. static tree
  639. ffeste_io_dolio_ (ffebld expr)
  640. {
  641.   tree type_id;
  642.   tree num_elements;
  643.   tree variable;
  644.   tree size;
  645.   tree arglist;
  646.   ffeinfoBasictype bt;
  647.   ffeinfoKindtype kt;
  648.   int tc;
  649.  
  650.   bt = ffeinfo_basictype (ffebld_info (expr));
  651.   kt = ffeinfo_kindtype (ffebld_info (expr));
  652.  
  653.   if ((bt == FFEINFO_basictypeANY)
  654.       || (kt == FFEINFO_kindtypeANY))
  655.     return error_mark_node;
  656.  
  657.   ffecom_push_calltemps ();
  658.  
  659.   tc = ffecom_f2c_typecode (bt, kt);
  660.   assert (tc != -1);
  661.   type_id = build_int_2 (tc, 0);
  662.  
  663.   type_id
  664.     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
  665.         convert (ffecom_f2c_ftnint_type_node,
  666.              type_id));
  667.  
  668.   variable = ffecom_arg_ptr_to_expr (expr, &size);
  669.  
  670.   if ((type_id == error_mark_node)
  671.       || (variable == error_mark_node)
  672.       || (size == error_mark_node))
  673.     {
  674.       ffecom_pop_calltemps ();
  675.       return error_mark_node;
  676.     }
  677.  
  678.   if (size == NULL_TREE)    /* Already filled in for CHARACTER type. */
  679.     {                /* "(ftnlen) sizeof(type)" */
  680.       size = size_binop (CEIL_DIV_EXPR,
  681.              TYPE_SIZE (ffecom_tree_type[bt][kt]),
  682.              size_int (TYPE_PRECISION (char_type_node)));
  683. #if 0    /* Assume that while it is possible that char * is wider than
  684.        ftnlen, no object in Fortran space can get big enough for its
  685.        size to be wider than ftnlen.  I really hope nobody wastes
  686.        time debugging a case where it can!  */
  687.       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
  688.           >= TYPE_PRECISION (TREE_TYPE (size)));
  689. #endif
  690.       size = convert (ffecom_f2c_ftnlen_type_node, size);
  691.     }
  692.  
  693.   if ((ffeinfo_rank (ffebld_info (expr)) == 0)
  694.       || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
  695.     num_elements = ffecom_integer_one_node;
  696.   else
  697.     {
  698.       num_elements = size_binop (CEIL_DIV_EXPR,
  699.             TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
  700.       num_elements = size_binop (CEIL_DIV_EXPR,
  701.                  num_elements, size_int (TYPE_PRECISION
  702.                              (char_type_node)));
  703.       num_elements = convert (ffecom_f2c_ftnlen_type_node,
  704.                   num_elements);
  705.     }
  706.  
  707.   num_elements
  708.     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
  709.         num_elements);
  710.  
  711.   variable = convert (string_type_node, variable);
  712.  
  713.   arglist = build_tree_list (NULL_TREE, type_id);
  714.   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements);
  715.   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable);
  716.   TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
  717.     = build_tree_list (NULL_TREE, size);
  718.  
  719.   ffecom_pop_calltemps ();
  720.  
  721.   return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist);
  722. }
  723.  
  724. #endif
  725. /* ffeste_io_douio_ -- Generate call to do_uio for unformatted I/O item
  726.  
  727.    ffebld expr;
  728.    tree call;
  729.    call = ffeste_io_douio_(expr);
  730.  
  731.    Returns a tree for a CALL_EXPR to the do_uio function, which handles
  732.    an unformatted I/O list item, along with the appropriate arguments for
  733.    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
  734.    for the CALL_EXPR, expand (emit) the expression, emit any assignment
  735.    of the result to an IOSTAT= variable, and emit any checking of the
  736.    result for errors.  */
  737.  
  738. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  739. static tree
  740. ffeste_io_douio_ (ffebld expr)
  741. {
  742.   tree num_elements;
  743.   tree variable;
  744.   tree size;
  745.   tree arglist;
  746.   ffeinfoBasictype bt;
  747.   ffeinfoKindtype kt;
  748.   bool is_complex;
  749.  
  750.   bt = ffeinfo_basictype (ffebld_info (expr));
  751.   kt = ffeinfo_kindtype (ffebld_info (expr));
  752.  
  753.   if ((bt == FFEINFO_basictypeANY)
  754.       || (kt == FFEINFO_kindtypeANY))
  755.     return error_mark_node;
  756.  
  757.   if (bt == FFEINFO_basictypeCOMPLEX)
  758.     {
  759.       is_complex = TRUE;
  760.       bt = FFEINFO_basictypeREAL;
  761.     }
  762.   else
  763.     is_complex = FALSE;
  764.  
  765.   ffecom_push_calltemps ();
  766.  
  767.   variable = ffecom_arg_ptr_to_expr (expr, &size);
  768.  
  769.   if ((variable == error_mark_node)
  770.       || (size == error_mark_node))
  771.     {
  772.       ffecom_pop_calltemps ();
  773.       return error_mark_node;
  774.     }
  775.  
  776.   if (size == NULL_TREE)    /* Already filled in for CHARACTER type. */
  777.     {                /* "(ftnlen) sizeof(type)" */
  778.       size = size_binop (CEIL_DIV_EXPR,
  779.              TYPE_SIZE (ffecom_tree_type[bt][kt]),
  780.              size_int (TYPE_PRECISION (char_type_node)));
  781. #if 0    /* Assume that while it is possible that char * is wider than
  782.        ftnlen, no object in Fortran space can get big enough for its
  783.        size to be wider than ftnlen.  I really hope nobody wastes
  784.        time debugging a case where it can!  */
  785.       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
  786.           >= TYPE_PRECISION (TREE_TYPE (size)));
  787. #endif
  788.       size = convert (ffecom_f2c_ftnlen_type_node, size);
  789.     }
  790.  
  791.   if ((ffeinfo_rank (ffebld_info (expr)) == 0)
  792.       || (TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE))
  793.     num_elements = is_complex ? ffecom_f2c_ftnlen_two_node
  794.       : ffecom_f2c_ftnlen_one_node;
  795.   else
  796.     {
  797.       num_elements = size_binop (CEIL_DIV_EXPR,
  798.             TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))), size);
  799.       num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
  800.                  size_int (TYPE_PRECISION
  801.                        (char_type_node)));
  802.       num_elements = convert (ffecom_f2c_ftnlen_type_node,
  803.                   num_elements);
  804.     }
  805.  
  806.   num_elements
  807.     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
  808.         num_elements);
  809.  
  810.   variable = convert (string_type_node, variable);
  811.  
  812.   arglist = build_tree_list (NULL_TREE, num_elements);
  813.   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
  814.   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
  815.  
  816.   ffecom_pop_calltemps ();
  817.  
  818.   return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist);
  819. }
  820.  
  821. #endif
  822. /* ffeste_io_ialist_ -- Make arglist with ptr to B/E/R control list
  823.  
  824.    tree arglist;
  825.    arglist = ffeste_io_ialist_(...);
  826.  
  827.    Returns a tree suitable as an argument list containing a pointer to
  828.    a BACKSPACE/ENDFILE/REWIND control list.  First, generates that control
  829.    list, if necessary, along with any static and run-time initializations
  830.    that are needed as specified by the arguments to this function.  */
  831.  
  832. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  833. static tree
  834. ffeste_io_ialist_ (bool have_err,
  835.            ffestvUnit unit,
  836.            ffebld unit_expr,
  837.            int unit_dflt)
  838. {
  839.   static tree f2c_alist_struct = NULL_TREE;
  840.   tree t;
  841.   tree ttype;
  842.   int yes;
  843.   tree field;
  844.   tree inits, initn;
  845.   bool constantp = TRUE;
  846.   static tree errfield, unitfield;
  847.   tree errinit, unitinit;
  848.   tree unitexp;
  849.   static int mynumber = 0;
  850.  
  851.   if (f2c_alist_struct == NULL_TREE)
  852.     {
  853.       tree ref;
  854.  
  855.       push_obstacks_nochange ();
  856.       end_temporary_allocation ();
  857.  
  858.       ref = make_node (RECORD_TYPE);
  859.  
  860.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  861.                     ffecom_f2c_flag_type_node);
  862.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  863.                      ffecom_f2c_ftnint_type_node);
  864.  
  865.       TYPE_FIELDS (ref) = errfield;
  866.       layout_type (ref);
  867.  
  868.       resume_temporary_allocation ();
  869.       pop_obstacks ();
  870.  
  871.       f2c_alist_struct = ref;
  872.     }
  873.  
  874.   ffeste_f2c_flagspec_ (have_err, errinit);
  875.  
  876.   switch (unit)
  877.     {
  878.     case FFESTV_unitNONE:
  879.     case FFESTV_unitASTERISK:
  880.       unitinit = build_int_2 (unit_dflt, 0);
  881.       unitexp = NULL_TREE;
  882.       break;
  883.  
  884.     case FFESTV_unitINTEXPR:
  885.       unitexp = ffecom_expr (unit_expr);
  886.       if (TREE_CONSTANT (unitexp))
  887.     {
  888.       unitinit = unitexp;
  889.       unitexp = NULL_TREE;
  890.     }
  891.       else
  892.     {
  893.       unitinit = ffecom_integer_zero_node;
  894.       constantp = FALSE;
  895.     }
  896.       break;
  897.  
  898.     default:
  899.       assert ("bad unit spec" == NULL);
  900.       unitexp = NULL_TREE;
  901.       unitinit = ffecom_integer_zero_node;
  902.       break;
  903.     }
  904.  
  905.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
  906.   initn = inits;
  907.   ffeste_f2c_init_ (unitinit);
  908.  
  909.   inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
  910.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  911.   TREE_STATIC (inits) = 1;
  912.  
  913.   yes = suspend_momentary ();
  914.  
  915.   t = build_decl (VAR_DECL,
  916.           ffecom_get_invented_identifier ("__g77_alist_%d", NULL,
  917.                           mynumber++),
  918.           f2c_alist_struct);
  919.   TREE_STATIC (t) = 1;
  920.   t = ffecom_start_decl (t, 1);
  921.   ffecom_finish_decl (t, inits, 0);
  922.  
  923.   resume_momentary (yes);
  924.  
  925.   ffeste_f2c_exp_ (unitfield, unitexp);
  926.  
  927.   ttype = build_pointer_type (TREE_TYPE (t));
  928.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  929.  
  930.   t = build_tree_list (NULL_TREE, t);
  931.  
  932.   return t;
  933. }
  934.  
  935. #endif
  936. /* ffeste_io_cilist_ -- Make arglist with ptr to external I/O control list
  937.  
  938.    tree arglist;
  939.    arglist = ffeste_io_cilist_(...);
  940.  
  941.    Returns a tree suitable as an argument list containing a pointer to
  942.    an external-file I/O control list.  First, generates that control
  943.    list, if necessary, along with any static and run-time initializations
  944.    that are needed as specified by the arguments to this function.  */
  945.  
  946. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  947. static tree
  948. ffeste_io_cilist_ (bool have_err,
  949.            ffestvUnit unit,
  950.            ffebld unit_expr,
  951.            int unit_dflt,
  952.            bool have_end,
  953.            ffestvFormat format,
  954.            ffestpFile *format_spec,
  955.            bool rec,
  956.            ffebld rec_expr)
  957. {
  958.   static tree f2c_cilist_struct = NULL_TREE;
  959.   tree t;
  960.   tree ttype;
  961.   int yes;
  962.   tree field;
  963.   tree inits, initn;
  964.   tree ignore;            /* We ignore the length of format! */
  965.   bool constantp = TRUE;
  966.   static tree errfield, unitfield, endfield, formatfield, recfield;
  967.   tree errinit, unitinit, endinit, formatinit, recinit;
  968.   tree unitexp, formatexp, recexp;
  969.   static int mynumber = 0;
  970.  
  971.   if (f2c_cilist_struct == NULL_TREE)
  972.     {
  973.       tree ref;
  974.  
  975.       push_obstacks_nochange ();
  976.       end_temporary_allocation ();
  977.  
  978.       ref = make_node (RECORD_TYPE);
  979.  
  980.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  981.                     ffecom_f2c_flag_type_node);
  982.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  983.                      ffecom_f2c_ftnint_type_node);
  984.       endfield = ffecom_decl_field (ref, unitfield, "end",
  985.                     ffecom_f2c_flag_type_node);
  986.       formatfield = ffecom_decl_field (ref, endfield, "format",
  987.                        string_type_node);
  988.       recfield = ffecom_decl_field (ref, formatfield, "rec",
  989.                     ffecom_f2c_ftnint_type_node);
  990.  
  991.       TYPE_FIELDS (ref) = errfield;
  992.       layout_type (ref);
  993.  
  994.       resume_temporary_allocation ();
  995.       pop_obstacks ();
  996.  
  997.       f2c_cilist_struct = ref;
  998.     }
  999.  
  1000.   ffeste_f2c_flagspec_ (have_err, errinit);
  1001.  
  1002.   switch (unit)
  1003.     {
  1004.     case FFESTV_unitNONE:
  1005.     case FFESTV_unitASTERISK:
  1006.       unitinit = build_int_2 (unit_dflt, 0);
  1007.       unitexp = NULL_TREE;
  1008.       break;
  1009.  
  1010.     case FFESTV_unitINTEXPR:
  1011.       unitexp = ffecom_expr (unit_expr);
  1012.       if (TREE_CONSTANT (unitexp))
  1013.     {
  1014.       unitinit = unitexp;
  1015.       unitexp = NULL_TREE;
  1016.     }
  1017.       else
  1018.     {
  1019.       unitinit = ffecom_integer_zero_node;
  1020.       constantp = FALSE;
  1021.     }
  1022.       break;
  1023.  
  1024.     default:
  1025.       assert ("bad unit spec" == NULL);
  1026.       unitexp = NULL_TREE;
  1027.       unitinit = ffecom_integer_zero_node;
  1028.       break;
  1029.     }
  1030.  
  1031.   switch (format)
  1032.     {
  1033.     case FFESTV_formatNONE:
  1034.       formatinit = null_pointer_node;
  1035.       formatexp = NULL_TREE;
  1036.       break;
  1037.  
  1038.     case FFESTV_formatLABEL:
  1039.       formatexp = NULL_TREE;
  1040.       formatinit = ffecom_lookup_label (format_spec->u.label);
  1041.       if ((formatinit == NULL_TREE)
  1042.       || (TREE_CODE (formatinit) == ERROR_MARK))
  1043.     break;
  1044.       formatinit = ffecom_1 (ADDR_EXPR,
  1045.                  build_pointer_type (void_type_node),
  1046.                  formatinit);
  1047.       TREE_CONSTANT (formatinit) = 1;
  1048.       break;
  1049.  
  1050.     case FFESTV_formatCHAREXPR:
  1051.       formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore);
  1052.       if (TREE_CONSTANT (formatexp))
  1053.     {
  1054.       formatinit = formatexp;
  1055.       formatexp = NULL_TREE;
  1056.     }
  1057.       else
  1058.     {
  1059.       formatinit = null_pointer_node;
  1060.       constantp = FALSE;
  1061.     }
  1062.       break;
  1063.  
  1064.     case FFESTV_formatASTERISK:
  1065.       formatinit = null_pointer_node;
  1066.       formatexp = NULL_TREE;
  1067.       break;
  1068.  
  1069.     case FFESTV_formatINTEXPR:
  1070.       formatinit = null_pointer_node;
  1071.       formatexp = ffecom_expr_assign (format_spec->u.expr);
  1072.       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
  1073.       < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
  1074.     error ("Cannot safely convert to assigned-FORMAT an expression\
  1075.  narrower than a pointer");
  1076.       formatexp = convert (string_type_node, formatexp);
  1077.       break;
  1078.  
  1079.     case FFESTV_formatNAMELIST:
  1080.       formatinit = ffecom_expr (format_spec->u.expr);
  1081.       formatexp = NULL_TREE;
  1082.       break;
  1083.  
  1084.     default:
  1085.       assert ("bad format spec" == NULL);
  1086.       formatexp = NULL_TREE;
  1087.       formatinit = integer_zero_node;
  1088.       break;
  1089.     }
  1090.  
  1091.   ffeste_f2c_flagspec_ (have_end, endinit);
  1092.  
  1093.   if (rec)
  1094.     recexp = ffecom_expr (rec_expr);
  1095.   else
  1096.     recexp = ffecom_integer_zero_node;
  1097.   if (TREE_CONSTANT (recexp))
  1098.     {
  1099.       recinit = recexp;
  1100.       recexp = NULL_TREE;
  1101.     }
  1102.   else
  1103.     {
  1104.       recinit = ffecom_integer_zero_node;
  1105.       constantp = FALSE;
  1106.     }
  1107.  
  1108.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
  1109.   initn = inits;
  1110.   ffeste_f2c_init_ (unitinit);
  1111.   ffeste_f2c_init_ (endinit);
  1112.   ffeste_f2c_init_ (formatinit);
  1113.   ffeste_f2c_init_ (recinit);
  1114.  
  1115.   inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
  1116.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  1117.   TREE_STATIC (inits) = 1;
  1118.  
  1119.   yes = suspend_momentary ();
  1120.  
  1121.   t = build_decl (VAR_DECL,
  1122.           ffecom_get_invented_identifier ("__g77_cilist_%d", NULL,
  1123.                           mynumber++),
  1124.           f2c_cilist_struct);
  1125.   TREE_STATIC (t) = 1;
  1126.   t = ffecom_start_decl (t, 1);
  1127.   ffecom_finish_decl (t, inits, 0);
  1128.  
  1129.   resume_momentary (yes);
  1130.  
  1131.   ffeste_f2c_exp_ (unitfield, unitexp);
  1132.   ffeste_f2c_exp_ (formatfield, formatexp);
  1133.   ffeste_f2c_exp_ (recfield, recexp);
  1134.  
  1135.   ttype = build_pointer_type (TREE_TYPE (t));
  1136.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  1137.  
  1138.   t = build_tree_list (NULL_TREE, t);
  1139.  
  1140.   return t;
  1141. }
  1142.  
  1143. #endif
  1144. /* ffeste_io_cllist_ -- Make arglist with ptr to CLOSE control list
  1145.  
  1146.    tree arglist;
  1147.    arglist = ffeste_io_cllist_(...);
  1148.  
  1149.    Returns a tree suitable as an argument list containing a pointer to
  1150.    a CLOSE-statement control list.  First, generates that control
  1151.    list, if necessary, along with any static and run-time initializations
  1152.    that are needed as specified by the arguments to this function.  */
  1153.  
  1154. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1155. static tree
  1156. ffeste_io_cllist_ (bool have_err,
  1157.            ffebld unit_expr,
  1158.            ffestpFile *stat_spec)
  1159. {
  1160.   static tree f2c_close_struct = NULL_TREE;
  1161.   tree t;
  1162.   tree ttype;
  1163.   int yes;
  1164.   tree field;
  1165.   tree inits, initn;
  1166.   tree ignore;            /* Ignore length info for certain fields. */
  1167.   bool constantp = TRUE;
  1168.   static tree errfield, unitfield, statfield;
  1169.   tree errinit, unitinit, statinit;
  1170.   tree unitexp, statexp;
  1171.   static int mynumber = 0;
  1172.  
  1173.   if (f2c_close_struct == NULL_TREE)
  1174.     {
  1175.       tree ref;
  1176.  
  1177.       push_obstacks_nochange ();
  1178.       end_temporary_allocation ();
  1179.  
  1180.       ref = make_node (RECORD_TYPE);
  1181.  
  1182.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  1183.                     ffecom_f2c_flag_type_node);
  1184.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  1185.                      ffecom_f2c_ftnint_type_node);
  1186.       statfield = ffecom_decl_field (ref, unitfield, "stat",
  1187.                      string_type_node);
  1188.  
  1189.       TYPE_FIELDS (ref) = errfield;
  1190.       layout_type (ref);
  1191.  
  1192.       resume_temporary_allocation ();
  1193.       pop_obstacks ();
  1194.  
  1195.       f2c_close_struct = ref;
  1196.     }
  1197.  
  1198.   ffeste_f2c_flagspec_ (have_err, errinit);
  1199.  
  1200.   unitexp = ffecom_expr (unit_expr);
  1201.   if (TREE_CONSTANT (unitexp))
  1202.     {
  1203.       unitinit = unitexp;
  1204.       unitexp = NULL_TREE;
  1205.     }
  1206.   else
  1207.     {
  1208.       unitinit = ffecom_integer_zero_node;
  1209.       constantp = FALSE;
  1210.     }
  1211.  
  1212.   ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
  1213.  
  1214.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
  1215.   initn = inits;
  1216.   ffeste_f2c_init_ (unitinit);
  1217.   ffeste_f2c_init_ (statinit);
  1218.  
  1219.   inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
  1220.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  1221.   TREE_STATIC (inits) = 1;
  1222.  
  1223.   yes = suspend_momentary ();
  1224.  
  1225.   t = build_decl (VAR_DECL,
  1226.           ffecom_get_invented_identifier ("__g77_cllist_%d", NULL,
  1227.                           mynumber++),
  1228.           f2c_close_struct);
  1229.   TREE_STATIC (t) = 1;
  1230.   t = ffecom_start_decl (t, 1);
  1231.   ffecom_finish_decl (t, inits, 0);
  1232.  
  1233.   resume_momentary (yes);
  1234.  
  1235.   ffeste_f2c_exp_ (unitfield, unitexp);
  1236.   ffeste_f2c_exp_ (statfield, statexp);
  1237.  
  1238.   ttype = build_pointer_type (TREE_TYPE (t));
  1239.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  1240.  
  1241.   t = build_tree_list (NULL_TREE, t);
  1242.  
  1243.   return t;
  1244. }
  1245.  
  1246. #endif
  1247. /* ffeste_io_icilist_ -- Make arglist with ptr to internal I/O control list
  1248.  
  1249.    tree arglist;
  1250.    arglist = ffeste_io_icilist_(...);
  1251.  
  1252.    Returns a tree suitable as an argument list containing a pointer to
  1253.    an internal-file I/O control list.  First, generates that control
  1254.    list, if necessary, along with any static and run-time initializations
  1255.    that are needed as specified by the arguments to this function.  */
  1256.  
  1257. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1258. static tree
  1259. ffeste_io_icilist_ (bool have_err,
  1260.             ffebld unit_expr,
  1261.             bool have_end,
  1262.             ffestvFormat format,
  1263.             ffestpFile *format_spec)
  1264. {
  1265.   static tree f2c_icilist_struct = NULL_TREE;
  1266.   tree t;
  1267.   tree ttype;
  1268.   int yes;
  1269.   tree field;
  1270.   tree inits, initn;
  1271.   tree ignore;            /* We ignore the length of format! */
  1272.   bool constantp = TRUE;
  1273.   static tree errfield, unitfield, endfield, formatfield, unitlenfield,
  1274.     unitnumfield;
  1275.   tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
  1276.   tree unitexp, formatexp, unitlenexp, unitnumexp;
  1277.   static int mynumber = 0;
  1278.  
  1279.   if (f2c_icilist_struct == NULL_TREE)
  1280.     {
  1281.       tree ref;
  1282.  
  1283.       push_obstacks_nochange ();
  1284.       end_temporary_allocation ();
  1285.  
  1286.       ref = make_node (RECORD_TYPE);
  1287.  
  1288.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  1289.                     ffecom_f2c_flag_type_node);
  1290.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  1291.                      string_type_node);
  1292.       endfield = ffecom_decl_field (ref, unitfield, "end",
  1293.                     ffecom_f2c_flag_type_node);
  1294.       formatfield = ffecom_decl_field (ref, endfield, "format",
  1295.                        string_type_node);
  1296.       unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
  1297.                     ffecom_f2c_ftnint_type_node);
  1298.       unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
  1299.                     ffecom_f2c_ftnint_type_node);
  1300.  
  1301.       TYPE_FIELDS (ref) = errfield;
  1302.       layout_type (ref);
  1303.  
  1304.       resume_temporary_allocation ();
  1305.       pop_obstacks ();
  1306.  
  1307.       f2c_icilist_struct = ref;
  1308.     }
  1309.  
  1310.   ffeste_f2c_flagspec_ (have_err, errinit);
  1311.  
  1312.   unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
  1313.   if ((ffeinfo_rank (ffebld_info (unit_expr)) == 0)
  1314.       || (TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
  1315.     unitnumexp = ffecom_integer_one_node;
  1316.   else
  1317.     {
  1318.       unitnumexp = size_binop (CEIL_DIV_EXPR,
  1319.            TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), unitlenexp);
  1320.       unitnumexp = size_binop (CEIL_DIV_EXPR,
  1321.                    unitnumexp, size_int (TYPE_PRECISION
  1322.                              (char_type_node)));
  1323.     }
  1324.   if (TREE_CONSTANT (unitexp))
  1325.     {
  1326.       unitinit = unitexp;
  1327.       unitexp = NULL_TREE;
  1328.     }
  1329.   else
  1330.     {
  1331.       unitinit = null_pointer_node;
  1332.       constantp = FALSE;
  1333.     }
  1334.   if ((unitlenexp != NULL_TREE) && TREE_CONSTANT (unitlenexp))
  1335.     {
  1336.       unitleninit = unitlenexp;
  1337.       unitlenexp = NULL_TREE;
  1338.     }
  1339.   else
  1340.     {
  1341.       unitleninit = ffecom_integer_zero_node;
  1342.       constantp = FALSE;
  1343.     }
  1344.   if (TREE_CONSTANT (unitnumexp))
  1345.     {
  1346.       unitnuminit = unitnumexp;
  1347.       unitnumexp = NULL_TREE;
  1348.     }
  1349.   else
  1350.     {
  1351.       unitnuminit = ffecom_integer_zero_node;
  1352.       constantp = FALSE;
  1353.     }
  1354.  
  1355.   switch (format)
  1356.     {
  1357.     case FFESTV_formatNONE:
  1358.       formatinit = null_pointer_node;
  1359.       formatexp = NULL_TREE;
  1360.       break;
  1361.  
  1362.     case FFESTV_formatLABEL:
  1363.       formatexp = NULL_TREE;
  1364.       formatinit = ffecom_lookup_label (format_spec->u.label);
  1365.       if ((formatinit == NULL_TREE)
  1366.       || (TREE_CODE (formatinit) == ERROR_MARK))
  1367.     break;
  1368.       formatinit = ffecom_1 (ADDR_EXPR,
  1369.                  build_pointer_type (void_type_node),
  1370.                  formatinit);
  1371.       TREE_CONSTANT (formatinit) = 1;
  1372.       break;
  1373.  
  1374.     case FFESTV_formatCHAREXPR:
  1375.       formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, &ignore);
  1376.       if (TREE_CONSTANT (formatexp))
  1377.     {
  1378.       formatinit = formatexp;
  1379.       formatexp = NULL_TREE;
  1380.     }
  1381.       else
  1382.     {
  1383.       formatinit = null_pointer_node;
  1384.       constantp = FALSE;
  1385.     }
  1386.       break;
  1387.  
  1388.     case FFESTV_formatASTERISK:
  1389.       formatinit = null_pointer_node;
  1390.       formatexp = NULL_TREE;
  1391.       break;
  1392.  
  1393.     case FFESTV_formatINTEXPR:
  1394.       formatinit = null_pointer_node;
  1395.       formatexp = ffecom_expr_assign (format_spec->u.expr);
  1396.       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
  1397.       < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
  1398.     error ("Cannot safely convert to assigned-FORMAT an expression\
  1399.  narrower than a pointer");
  1400.       formatexp = convert (string_type_node, formatexp);
  1401.       break;
  1402.  
  1403.     default:
  1404.       assert ("bad format spec" == NULL);
  1405.       formatexp = NULL_TREE;
  1406.       formatinit = ffecom_integer_zero_node;
  1407.       break;
  1408.     }
  1409.  
  1410.   ffeste_f2c_flagspec_ (have_end, endinit);
  1411.  
  1412.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
  1413.                errinit);
  1414.   initn = inits;
  1415.   ffeste_f2c_init_ (unitinit);
  1416.   ffeste_f2c_init_ (endinit);
  1417.   ffeste_f2c_init_ (formatinit);
  1418.   ffeste_f2c_init_ (unitleninit);
  1419.   ffeste_f2c_init_ (unitnuminit);
  1420.  
  1421.   inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
  1422.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  1423.   TREE_STATIC (inits) = 1;
  1424.  
  1425.   yes = suspend_momentary ();
  1426.  
  1427.   t = build_decl (VAR_DECL,
  1428.           ffecom_get_invented_identifier ("__g77_icilist_%d", NULL,
  1429.                           mynumber++),
  1430.           f2c_icilist_struct);
  1431.   TREE_STATIC (t) = 1;
  1432.   t = ffecom_start_decl (t, 1);
  1433.   ffecom_finish_decl (t, inits, 0);
  1434.  
  1435.   resume_momentary (yes);
  1436.  
  1437.   ffeste_f2c_exp_ (unitfield, unitexp);
  1438.   ffeste_f2c_exp_ (formatfield, formatexp);
  1439.   ffeste_f2c_exp_ (unitlenfield, unitlenexp);
  1440.   ffeste_f2c_exp_ (unitnumfield, unitnumexp);
  1441.  
  1442.   ttype = build_pointer_type (TREE_TYPE (t));
  1443.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  1444.  
  1445.   t = build_tree_list (NULL_TREE, t);
  1446.  
  1447.   return t;
  1448. }
  1449.  
  1450. #endif
  1451. /* ffeste_io_impdo_ -- Handle implied-DO in I/O list
  1452.  
  1453.    ffebld expr;
  1454.    ffeste_io_impdo_(expr);
  1455.  
  1456.    Expands code to start up the DO loop.  Then for each item in the
  1457.    DO loop, handles appropriately (possibly including recursively calling
  1458.    itself).  Then expands code to end the DO loop.  */
  1459.  
  1460. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1461. static void
  1462. ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
  1463. {
  1464.   ffebld var = ffebld_head (ffebld_right (impdo));
  1465.   ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
  1466.   ffebld end = ffebld_head (ffebld_trail (ffebld_trail
  1467.                       (ffebld_right (impdo))));
  1468.   ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
  1469.                     (ffebld_trail (ffebld_right (impdo)))));
  1470.   ffebld list;            /* Used for list of items in left part of
  1471.                    impdo. */
  1472.   ffebld item;            /* I/O item from head of given list. */
  1473.   tree tvar;
  1474.   tree tincr;
  1475.   tree titervar;
  1476.  
  1477.   if (incr == NULL)
  1478.     {
  1479.       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
  1480.       ffebld_set_info (incr, ffeinfo_new
  1481.                (FFEINFO_basictypeINTEGER,
  1482.             FFEINFO_kindtypeINTEGERDEFAULT,
  1483.             0,
  1484.             FFEINFO_kindENTITY,
  1485.             FFEINFO_whereCONSTANT,
  1486.             FFETARGET_charactersizeNONE));
  1487.     }
  1488.  
  1489.   /* Start the DO loop.  */
  1490.  
  1491.   ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
  1492.             start, impdo_token,
  1493.             end, impdo_token,
  1494.             incr, impdo_token,
  1495.             "Implied DO loop");
  1496.  
  1497.   /* Handle the list of items.  */
  1498.  
  1499.   for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
  1500.     {
  1501.       item = ffebld_head (list);
  1502.       if (item == NULL)
  1503.     continue;
  1504.       while (ffebld_op (item) == FFEBLD_opPAREN)
  1505.     item = ffebld_left (item);
  1506.       if (ffebld_op (item) == FFEBLD_opANY)
  1507.     continue;
  1508.       if (ffebld_op (item) == FFEBLD_opIMPDO)
  1509.     ffeste_io_impdo_ (item, impdo_token);
  1510.       else
  1511.     ffeste_io_call_ ((*ffeste_io_driver_) (item),
  1512.              (ffeste_io_abort_ != NULL_TREE));
  1513.       clear_momentary ();
  1514.     }
  1515.  
  1516.   /* Generate end of implied-do construct. */
  1517.  
  1518.   ffeste_end_iterdo_ (tvar, tincr, titervar);
  1519. }
  1520.  
  1521. #endif
  1522. /* ffeste_io_inlist_ -- Make arglist with ptr to INQUIRE control list
  1523.  
  1524.    tree arglist;
  1525.    arglist = ffeste_io_inlist_(...);
  1526.  
  1527.    Returns a tree suitable as an argument list containing a pointer to
  1528.    an INQUIRE-statement control list.  First, generates that control
  1529.    list, if necessary, along with any static and run-time initializations
  1530.    that are needed as specified by the arguments to this function.  */
  1531.  
  1532. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1533. static tree
  1534. ffeste_io_inlist_ (bool have_err,
  1535.            ffestpFile *unit_spec,
  1536.            ffestpFile *file_spec,
  1537.            ffestpFile *exist_spec,
  1538.            ffestpFile *open_spec,
  1539.            ffestpFile *number_spec,
  1540.            ffestpFile *named_spec,
  1541.            ffestpFile *name_spec,
  1542.            ffestpFile *access_spec,
  1543.            ffestpFile *sequential_spec,
  1544.            ffestpFile *direct_spec,
  1545.            ffestpFile *form_spec,
  1546.            ffestpFile *formatted_spec,
  1547.            ffestpFile *unformatted_spec,
  1548.            ffestpFile *recl_spec,
  1549.            ffestpFile *nextrec_spec,
  1550.            ffestpFile *blank_spec)
  1551. {
  1552.   static tree f2c_inquire_struct = NULL_TREE;
  1553.   tree t;
  1554.   tree ttype;
  1555.   int yes;
  1556.   tree field;
  1557.   tree inits, initn;
  1558.   bool constantp = TRUE;
  1559.   static tree errfield, unitfield, filefield, filelenfield, existfield,
  1560.     openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
  1561.     accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
  1562.     formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
  1563.     unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
  1564.   tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
  1565.     namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
  1566.     sequentialleninit, directinit, directleninit, forminit, formleninit,
  1567.     formattedinit, formattedleninit, unformattedinit, unformattedleninit,
  1568.     reclinit, nextrecinit, blankinit, blankleninit;
  1569.   tree
  1570.     unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
  1571.     nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
  1572.     directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
  1573.     unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
  1574.   static int mynumber = 0;
  1575.  
  1576.   if (f2c_inquire_struct == NULL_TREE)
  1577.     {
  1578.       tree ref;
  1579.  
  1580.       push_obstacks_nochange ();
  1581.       end_temporary_allocation ();
  1582.  
  1583.       ref = make_node (RECORD_TYPE);
  1584.  
  1585.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  1586.                     ffecom_f2c_flag_type_node);
  1587.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  1588.                      ffecom_f2c_ftnint_type_node);
  1589.       filefield = ffecom_decl_field (ref, unitfield, "file",
  1590.                      string_type_node);
  1591.       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
  1592.                     ffecom_f2c_ftnlen_type_node);
  1593.       existfield = ffecom_decl_field (ref, filelenfield, "exist",
  1594.                       ffecom_f2c_ptr_to_ftnint_type_node);
  1595.       openfield = ffecom_decl_field (ref, existfield, "open",
  1596.                      ffecom_f2c_ptr_to_ftnint_type_node);
  1597.       numberfield = ffecom_decl_field (ref, openfield, "number",
  1598.                        ffecom_f2c_ptr_to_ftnint_type_node);
  1599.       namedfield = ffecom_decl_field (ref, numberfield, "named",
  1600.                       ffecom_f2c_ptr_to_ftnint_type_node);
  1601.       namefield = ffecom_decl_field (ref, namedfield, "name",
  1602.                      string_type_node);
  1603.       namelenfield = ffecom_decl_field (ref, namefield, "namelen",
  1604.                     ffecom_f2c_ftnlen_type_node);
  1605.       accessfield = ffecom_decl_field (ref, namelenfield, "access",
  1606.                        string_type_node);
  1607.       accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
  1608.                       ffecom_f2c_ftnlen_type_node);
  1609.       sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
  1610.                        string_type_node);
  1611.       sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
  1612.                           "sequentiallen",
  1613.                           ffecom_f2c_ftnlen_type_node);
  1614.       directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
  1615.                        string_type_node);
  1616.       directlenfield = ffecom_decl_field (ref, directfield, "directlen",
  1617.                       ffecom_f2c_ftnlen_type_node);
  1618.       formfield = ffecom_decl_field (ref, directlenfield, "form",
  1619.                      string_type_node);
  1620.       formlenfield = ffecom_decl_field (ref, formfield, "formlen",
  1621.                     ffecom_f2c_ftnlen_type_node);
  1622.       formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
  1623.                       string_type_node);
  1624.       formattedlenfield = ffecom_decl_field (ref, formattedfield,
  1625.                          "formattedlen",
  1626.                          ffecom_f2c_ftnlen_type_node);
  1627.       unformattedfield = ffecom_decl_field (ref, formattedlenfield,
  1628.                         "unformatted",
  1629.                         string_type_node);
  1630.       unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
  1631.                            "unformattedlen",
  1632.                            ffecom_f2c_ftnlen_type_node);
  1633.       reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
  1634.                      ffecom_f2c_ptr_to_ftnint_type_node);
  1635.       nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
  1636.                     ffecom_f2c_ptr_to_ftnint_type_node);
  1637.       blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
  1638.                       string_type_node);
  1639.       blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
  1640.                      ffecom_f2c_ftnlen_type_node);
  1641.  
  1642.       TYPE_FIELDS (ref) = errfield;
  1643.       layout_type (ref);
  1644.  
  1645.       resume_temporary_allocation ();
  1646.       pop_obstacks ();
  1647.  
  1648.       f2c_inquire_struct = ref;
  1649.     }
  1650.  
  1651.   ffeste_f2c_flagspec_ (have_err, errinit);
  1652.   ffeste_f2c_intspec_ (unit_spec, unitexp, unitinit);
  1653.   ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
  1654.   ffeste_f2c_ptrtointspec_ (exist_spec, existexp, existinit);
  1655.   ffeste_f2c_ptrtointspec_ (open_spec, openexp, openinit);
  1656.   ffeste_f2c_ptrtointspec_ (number_spec, numberexp, numberinit);
  1657.   ffeste_f2c_ptrtointspec_ (named_spec, namedexp, namedinit);
  1658.   ffeste_f2c_charspec_ (name_spec, nameexp, nameinit, namelenexp, nameleninit);
  1659.   ffeste_f2c_charspec_ (access_spec, accessexp, accessinit, accesslenexp,
  1660.             accessleninit);
  1661.   ffeste_f2c_charspec_ (sequential_spec, sequentialexp, sequentialinit,
  1662.             sequentiallenexp, sequentialleninit);
  1663.   ffeste_f2c_charspec_ (direct_spec, directexp, directinit, directlenexp,
  1664.             directleninit);
  1665.   ffeste_f2c_charspec_ (form_spec, formexp, forminit, formlenexp, formleninit);
  1666.   ffeste_f2c_charspec_ (formatted_spec, formattedexp, formattedinit,
  1667.             formattedlenexp, formattedleninit);
  1668.   ffeste_f2c_charspec_ (unformatted_spec, unformattedexp, unformattedinit,
  1669.             unformattedlenexp, unformattedleninit);
  1670.   ffeste_f2c_ptrtointspec_ (recl_spec, reclexp, reclinit);
  1671.   ffeste_f2c_ptrtointspec_ (nextrec_spec, nextrecexp, nextrecinit);
  1672.   ffeste_f2c_charspec_ (blank_spec, blankexp, blankinit, blanklenexp,
  1673.             blankleninit);
  1674.  
  1675.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
  1676.                errinit);
  1677.   initn = inits;
  1678.   ffeste_f2c_init_ (unitinit);
  1679.   ffeste_f2c_init_ (fileinit);
  1680.   ffeste_f2c_init_ (fileleninit);
  1681.   ffeste_f2c_init_ (existinit);
  1682.   ffeste_f2c_init_ (openinit);
  1683.   ffeste_f2c_init_ (numberinit);
  1684.   ffeste_f2c_init_ (namedinit);
  1685.   ffeste_f2c_init_ (nameinit);
  1686.   ffeste_f2c_init_ (nameleninit);
  1687.   ffeste_f2c_init_ (accessinit);
  1688.   ffeste_f2c_init_ (accessleninit);
  1689.   ffeste_f2c_init_ (sequentialinit);
  1690.   ffeste_f2c_init_ (sequentialleninit);
  1691.   ffeste_f2c_init_ (directinit);
  1692.   ffeste_f2c_init_ (directleninit);
  1693.   ffeste_f2c_init_ (forminit);
  1694.   ffeste_f2c_init_ (formleninit);
  1695.   ffeste_f2c_init_ (formattedinit);
  1696.   ffeste_f2c_init_ (formattedleninit);
  1697.   ffeste_f2c_init_ (unformattedinit);
  1698.   ffeste_f2c_init_ (unformattedleninit);
  1699.   ffeste_f2c_init_ (reclinit);
  1700.   ffeste_f2c_init_ (nextrecinit);
  1701.   ffeste_f2c_init_ (blankinit);
  1702.   ffeste_f2c_init_ (blankleninit);
  1703.  
  1704.   inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
  1705.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  1706.   TREE_STATIC (inits) = 1;
  1707.  
  1708.   yes = suspend_momentary ();
  1709.  
  1710.   t = build_decl (VAR_DECL,
  1711.           ffecom_get_invented_identifier ("__g77_inlist_%d", NULL,
  1712.                           mynumber++),
  1713.           f2c_inquire_struct);
  1714.   TREE_STATIC (t) = 1;
  1715.   t = ffecom_start_decl (t, 1);
  1716.   ffecom_finish_decl (t, inits, 0);
  1717.  
  1718.   resume_momentary (yes);
  1719.  
  1720.   ffeste_f2c_exp_ (unitfield, unitexp);
  1721.   ffeste_f2c_exp_ (filefield, fileexp);
  1722.   ffeste_f2c_exp_ (filelenfield, filelenexp);
  1723.   ffeste_f2c_exp_ (existfield, existexp);
  1724.   ffeste_f2c_exp_ (openfield, openexp);
  1725.   ffeste_f2c_exp_ (numberfield, numberexp);
  1726.   ffeste_f2c_exp_ (namedfield, namedexp);
  1727.   ffeste_f2c_exp_ (namefield, nameexp);
  1728.   ffeste_f2c_exp_ (namelenfield, namelenexp);
  1729.   ffeste_f2c_exp_ (accessfield, accessexp);
  1730.   ffeste_f2c_exp_ (accesslenfield, accesslenexp);
  1731.   ffeste_f2c_exp_ (sequentialfield, sequentialexp);
  1732.   ffeste_f2c_exp_ (sequentiallenfield, sequentiallenexp);
  1733.   ffeste_f2c_exp_ (directfield, directexp);
  1734.   ffeste_f2c_exp_ (directlenfield, directlenexp);
  1735.   ffeste_f2c_exp_ (formfield, formexp);
  1736.   ffeste_f2c_exp_ (formlenfield, formlenexp);
  1737.   ffeste_f2c_exp_ (formattedfield, formattedexp);
  1738.   ffeste_f2c_exp_ (formattedlenfield, formattedlenexp);
  1739.   ffeste_f2c_exp_ (unformattedfield, unformattedexp);
  1740.   ffeste_f2c_exp_ (unformattedlenfield, unformattedlenexp);
  1741.   ffeste_f2c_exp_ (reclfield, reclexp);
  1742.   ffeste_f2c_exp_ (nextrecfield, nextrecexp);
  1743.   ffeste_f2c_exp_ (blankfield, blankexp);
  1744.   ffeste_f2c_exp_ (blanklenfield, blanklenexp);
  1745.  
  1746.   ttype = build_pointer_type (TREE_TYPE (t));
  1747.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  1748.  
  1749.   t = build_tree_list (NULL_TREE, t);
  1750.  
  1751.   return t;
  1752. }
  1753.  
  1754. #endif
  1755. /* ffeste_io_olist_ -- Make arglist with ptr to OPEN control list
  1756.  
  1757.    tree arglist;
  1758.    arglist = ffeste_io_olist_(...);
  1759.  
  1760.    Returns a tree suitable as an argument list containing a pointer to
  1761.    an OPEN-statement control list.  First, generates that control
  1762.    list, if necessary, along with any static and run-time initializations
  1763.    that are needed as specified by the arguments to this function.  */
  1764.  
  1765. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1766. static tree
  1767. ffeste_io_olist_ (bool have_err,
  1768.           ffebld unit_expr,
  1769.           ffestpFile *file_spec,
  1770.           ffestpFile *stat_spec,
  1771.           ffestpFile *access_spec,
  1772.           ffestpFile *form_spec,
  1773.           ffestpFile *recl_spec,
  1774.           ffestpFile *blank_spec)
  1775. {
  1776.   static tree f2c_open_struct = NULL_TREE;
  1777.   tree t;
  1778.   tree ttype;
  1779.   int yes;
  1780.   tree field;
  1781.   tree inits, initn;
  1782.   tree ignore;            /* Ignore length info for certain fields. */
  1783.   bool constantp = TRUE;
  1784.   static tree errfield, unitfield, filefield, filelenfield, statfield,
  1785.     accessfield, formfield, reclfield, blankfield;
  1786.   tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
  1787.     forminit, reclinit, blankinit;
  1788.   tree
  1789.     unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
  1790.     blankexp;
  1791.   static int mynumber = 0;
  1792.  
  1793.   if (f2c_open_struct == NULL_TREE)
  1794.     {
  1795.       tree ref;
  1796.  
  1797.       push_obstacks_nochange ();
  1798.       end_temporary_allocation ();
  1799.  
  1800.       ref = make_node (RECORD_TYPE);
  1801.  
  1802.       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
  1803.                     ffecom_f2c_flag_type_node);
  1804.       unitfield = ffecom_decl_field (ref, errfield, "unit",
  1805.                      ffecom_f2c_ftnint_type_node);
  1806.       filefield = ffecom_decl_field (ref, unitfield, "file",
  1807.                      string_type_node);
  1808.       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
  1809.                     ffecom_f2c_ftnlen_type_node);
  1810.       statfield = ffecom_decl_field (ref, filelenfield, "stat",
  1811.                      string_type_node);
  1812.       accessfield = ffecom_decl_field (ref, statfield, "access",
  1813.                        string_type_node);
  1814.       formfield = ffecom_decl_field (ref, accessfield, "form",
  1815.                      string_type_node);
  1816.       reclfield = ffecom_decl_field (ref, formfield, "recl",
  1817.                      ffecom_f2c_ftnint_type_node);
  1818.       blankfield = ffecom_decl_field (ref, reclfield, "blank",
  1819.                       string_type_node);
  1820.  
  1821.       TYPE_FIELDS (ref) = errfield;
  1822.       layout_type (ref);
  1823.  
  1824.       resume_temporary_allocation ();
  1825.       pop_obstacks ();
  1826.  
  1827.       f2c_open_struct = ref;
  1828.     }
  1829.  
  1830.   ffeste_f2c_flagspec_ (have_err, errinit);
  1831.  
  1832.   unitexp = ffecom_expr (unit_expr);
  1833.   if (TREE_CONSTANT (unitexp))
  1834.     {
  1835.       unitinit = unitexp;
  1836.       unitexp = NULL_TREE;
  1837.     }
  1838.   else
  1839.     {
  1840.       unitinit = ffecom_integer_zero_node;
  1841.       constantp = FALSE;
  1842.     }
  1843.  
  1844.   ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
  1845.   ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
  1846.   ffeste_f2c_charnolenspec_ (access_spec, accessexp, accessinit);
  1847.   ffeste_f2c_charnolenspec_ (form_spec, formexp, forminit);
  1848.   ffeste_f2c_intspec_ (recl_spec, reclexp, reclinit);
  1849.   ffeste_f2c_charnolenspec_ (blank_spec, blankexp, blankinit);
  1850.  
  1851.   inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
  1852.   initn = inits;
  1853.   ffeste_f2c_init_ (unitinit);
  1854.   ffeste_f2c_init_ (fileinit);
  1855.   ffeste_f2c_init_ (fileleninit);
  1856.   ffeste_f2c_init_ (statinit);
  1857.   ffeste_f2c_init_ (accessinit);
  1858.   ffeste_f2c_init_ (forminit);
  1859.   ffeste_f2c_init_ (reclinit);
  1860.   ffeste_f2c_init_ (blankinit);
  1861.  
  1862.   inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
  1863.   TREE_CONSTANT (inits) = constantp ? 1 : 0;
  1864.   TREE_STATIC (inits) = 1;
  1865.  
  1866.   yes = suspend_momentary ();
  1867.  
  1868.   t = build_decl (VAR_DECL,
  1869.           ffecom_get_invented_identifier ("__g77_olist_%d", NULL,
  1870.                           mynumber++),
  1871.           f2c_open_struct);
  1872.   TREE_STATIC (t) = 1;
  1873.   t = ffecom_start_decl (t, 1);
  1874.   ffecom_finish_decl (t, inits, 0);
  1875.  
  1876.   resume_momentary (yes);
  1877.  
  1878.   ffeste_f2c_exp_ (unitfield, unitexp);
  1879.   ffeste_f2c_exp_ (filefield, fileexp);
  1880.   ffeste_f2c_exp_ (filelenfield, filelenexp);
  1881.   ffeste_f2c_exp_ (statfield, statexp);
  1882.   ffeste_f2c_exp_ (accessfield, accessexp);
  1883.   ffeste_f2c_exp_ (formfield, formexp);
  1884.   ffeste_f2c_exp_ (reclfield, reclexp);
  1885.   ffeste_f2c_exp_ (blankfield, blankexp);
  1886.  
  1887.   ttype = build_pointer_type (TREE_TYPE (t));
  1888.   t = ffecom_1 (ADDR_EXPR, ttype, t);
  1889.  
  1890.   t = build_tree_list (NULL_TREE, t);
  1891.  
  1892.   return t;
  1893. }
  1894.  
  1895. #endif
  1896. /* ffeste_subr_file_ -- Display file-statement specifier
  1897.  
  1898.    ffeste_subr_file_(&specifier);  */
  1899.  
  1900. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  1901. static void
  1902. ffeste_subr_file_ (char *kw, ffestpFile *spec)
  1903. {
  1904.   if (!spec->kw_or_val_present)
  1905.     return;
  1906.   fputs (kw, stdout);
  1907.   if (spec->value_present)
  1908.     {
  1909.       fputc ('=', stdout);
  1910.       if (spec->value_is_label)
  1911.     {
  1912.       assert (spec->value_is_label == 2);    /* Temporary checking only. */
  1913.       fprintf (stdout, "%" ffelabValue_f "u",
  1914.            ffelab_value (spec->u.label));
  1915.     }
  1916.       else
  1917.     ffebld_dump (spec->u.expr);
  1918.     }
  1919.   fputc (',', stdout);
  1920. }
  1921. #endif
  1922.  
  1923. /* ffeste_subr_beru_ -- Generate code for BACKSPACE/ENDFILE/REWIND
  1924.  
  1925.    ffeste_subr_beru_(FFECOM_gfrtFBACK);     */
  1926.  
  1927. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1928. static void
  1929. ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
  1930. {
  1931.   tree alist;
  1932.   bool iostat;
  1933.   bool errl;
  1934.  
  1935. #define specified(something) (info->beru_spec[something].kw_or_val_present)
  1936.  
  1937.   ffeste_emit_line_note_ ();
  1938.  
  1939.   /* Do the real work. */
  1940.  
  1941.   iostat = specified (FFESTP_beruixIOSTAT);
  1942.   errl = specified (FFESTP_beruixERR);
  1943.  
  1944.   /* ~~For now, we assume the unit number is specified and is not ASTERISK,
  1945.      because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
  1946.      without any unit specifier.  f2c, however, supports the former
  1947.      construct.     When it is time to add this feature to the FFE, which
  1948.      probably is fairly easy, ffestc_R919 and company will want to pass an
  1949.      ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
  1950.      ffeste_R919 and company, and they will want to pass that same value to
  1951.      this function, and that argument will replace the constant _unitINTEXPR_
  1952.      in the call below.     Right now, the default unit number, 6, is ignored. */
  1953.  
  1954.   ffecom_push_calltemps ();
  1955.  
  1956.   alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
  1957.                  info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
  1958.  
  1959.   if (errl)
  1960.     {                /* ERR= */
  1961.       ffeste_io_err_
  1962.     = ffeste_io_abort_
  1963.     = ffecom_lookup_label
  1964.     (info->beru_spec[FFESTP_beruixERR].u.label);
  1965.       ffeste_io_abort_is_temp_ = FALSE;
  1966.     }
  1967.   else
  1968.     {                /* no ERR= */
  1969.       ffeste_io_err_ = NULL_TREE;
  1970.  
  1971.       if ((ffeste_io_abort_is_temp_ = iostat))
  1972.     ffeste_io_abort_ = ffecom_temp_label ();
  1973.       else
  1974.     ffeste_io_abort_ = NULL_TREE;
  1975.     }
  1976.  
  1977.   if (iostat)
  1978.     {                /* IOSTAT= */
  1979.       ffeste_io_iostat_is_temp_ = FALSE;
  1980.       ffeste_io_iostat_ = ffecom_expr
  1981.     (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
  1982.     }
  1983.   else if (ffeste_io_abort_ != NULL_TREE)
  1984.     {                /* no IOSTAT= but ERR= */
  1985.       ffeste_io_iostat_is_temp_ = TRUE;
  1986.       ffeste_io_iostat_
  1987.     = ffecom_push_tempvar (ffecom_integer_type_node,
  1988.                    FFETARGET_charactersizeNONE, -1, FALSE);
  1989.     }
  1990.   else
  1991.     {                /* no IOSTAT=, or ERR= */
  1992.       ffeste_io_iostat_is_temp_ = FALSE;
  1993.       ffeste_io_iostat_ = NULL_TREE;
  1994.     }
  1995.  
  1996.   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  1997.      label, since we're gonna fall through to there anyway. */
  1998.  
  1999.   ffeste_io_call_ (ffecom_call_gfrt (rt, alist),
  2000.            !ffeste_io_abort_is_temp_
  2001.            && (ffeste_io_abort_ != NULL_TREE));
  2002.  
  2003.   /* If we've got a temp label, generate its code here. */
  2004.  
  2005.   if (ffeste_io_abort_is_temp_)
  2006.     {
  2007.       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  2008.       emit_nop ();
  2009.       expand_label (ffeste_io_abort_);
  2010.  
  2011.       assert (ffeste_io_err_ == NULL_TREE);
  2012.     }
  2013.  
  2014.   /* If we've got a temp iostat, pop the temp. */
  2015.  
  2016.   if (ffeste_io_iostat_is_temp_)
  2017.     ffecom_pop_tempvar (ffeste_io_iostat_);
  2018.  
  2019.   ffecom_pop_calltemps ();
  2020.  
  2021. #undef specified
  2022.  
  2023.   clear_momentary ();
  2024. }
  2025.  
  2026. #endif
  2027. /* ffeste_do -- End of statement following DO-term-stmt etc
  2028.  
  2029.    ffeste_do(TRUE);
  2030.  
  2031.    Also invoked by _labeldef_branch_finish_ (or, in cases
  2032.    of errors, other _labeldef_ functions) when the label definition is
  2033.    for a DO-target (LOOPEND) label, once per matching/outstanding DO
  2034.    block on the stack.    These cases invoke this function with ok==TRUE, so
  2035.    only forced stack popping (via ffeste_eof_()) invokes it with ok==FALSE.  */
  2036.  
  2037. void
  2038. ffeste_do (ffestw block)
  2039. {
  2040. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2041.   fputs ("+ END_DO\n", stdout);
  2042. #else
  2043. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2044.   ffeste_emit_line_note_ ();
  2045.   if (ffestw_do_tvar (block) == 0)
  2046.     expand_end_loop ();        /* DO WHILE and just DO. */
  2047.   else
  2048.     ffeste_end_iterdo_ (ffestw_do_tvar (block),
  2049.             ffestw_do_incr_saved (block),
  2050.             ffestw_do_count_var (block));
  2051.  
  2052.   clear_momentary ();
  2053. #endif
  2054. #endif
  2055. }
  2056.  
  2057. /* ffeste_end_R807 -- End of statement following logical IF
  2058.  
  2059.    ffeste_end_R807(TRUE);
  2060.  
  2061.    Applies ONLY to logical IF, not to IF-THEN.    For example, does not
  2062.    ffelex_token_kill the construct name for an IF-THEN block (the name
  2063.    field is invalid for logical IF).  ok==TRUE iff statement following
  2064.    logical IF (substatement) is valid; else, statement is invalid or
  2065.    stack forcibly popped due to ffeste_eof_().    */
  2066.  
  2067. void
  2068. ffeste_end_R807 ()
  2069. {
  2070. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2071.   fputs ("+ END_IF\n", stdout);    /* Also see ffeste_R806. */
  2072. #else
  2073. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2074.   ffeste_emit_line_note_ ();
  2075.   expand_end_cond ();
  2076.   clear_momentary ();
  2077. #endif
  2078. #endif
  2079. }
  2080.  
  2081. /* ffeste_labeldef_branch -- Generate "code" for branch label def
  2082.  
  2083.    ffeste_labeldef_branch(label);  */
  2084.  
  2085. void
  2086. ffeste_labeldef_branch (ffelab label)
  2087. {
  2088. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2089.   fprintf (stdout, "+ label %lu\n", ffelab_value (label));
  2090. #else
  2091. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2092.   {
  2093.     tree glabel;
  2094.  
  2095.     glabel = ffecom_lookup_label (label);
  2096.     assert (glabel != NULL_TREE);
  2097.     if (TREE_CODE (glabel) == ERROR_MARK)
  2098.       return;
  2099.     assert (DECL_INITIAL (glabel) == NULL_TREE);
  2100.     DECL_INITIAL (glabel) = error_mark_node;
  2101.     DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
  2102.     DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
  2103.     emit_nop ();
  2104.     expand_label (glabel);
  2105.   }
  2106. #endif
  2107. #endif
  2108. }
  2109.  
  2110. /* ffeste_labeldef_format -- Generate "code" for FORMAT label def
  2111.  
  2112.    ffeste_labeldef_format(label);  */
  2113.  
  2114. void
  2115. ffeste_labeldef_format (ffelab label)
  2116. {
  2117. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2118.   fprintf (stdout, "$ label %lu\n", ffelab_value (label));
  2119. #else
  2120. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2121.   ffeste_label_formatdef_ = label;
  2122. #endif
  2123. #endif
  2124. }
  2125.  
  2126. /* ffeste_R737A -- Assignment statement outside of WHERE
  2127.  
  2128.    ffeste_R737A(dest_expr,source_expr);     */
  2129.  
  2130. void
  2131. ffeste_R737A (ffebld dest, ffebld source)
  2132. {
  2133.   ffeste_check_simple_ ();
  2134.  
  2135. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2136.   fputs ("+ let ", stdout);
  2137.   ffebld_dump (dest);
  2138.   fputs ("=", stdout);
  2139.   ffebld_dump (source);
  2140.   fputc ('\n', stdout);
  2141. #else
  2142. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2143.   ffeste_emit_line_note_ ();
  2144.   ffecom_push_calltemps ();
  2145.  
  2146.   ffecom_expand_let_stmt (dest, source);
  2147.  
  2148.   ffecom_pop_calltemps ();
  2149.   clear_momentary ();
  2150. #endif
  2151. #endif
  2152. }
  2153.  
  2154. /* ffeste_R803 -- Block IF (IF-THEN) statement
  2155.  
  2156.    ffeste_R803(construct_name,expr,expr_token);
  2157.  
  2158.    Make sure statement is valid here; implement.  */
  2159.  
  2160. void
  2161. ffeste_R803 (ffebld expr)
  2162. {
  2163.   ffeste_check_simple_ ();
  2164.  
  2165. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2166.   fputs ("+ IF_block (", stdout);
  2167.   ffebld_dump (expr);
  2168.   fputs (")\n", stdout);
  2169. #else
  2170. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2171.   ffeste_emit_line_note_ ();
  2172.   ffecom_push_calltemps ();
  2173.  
  2174.   expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
  2175.  
  2176.   ffecom_pop_calltemps ();
  2177.   clear_momentary ();
  2178. #endif
  2179. #endif
  2180. }
  2181.  
  2182. /* ffeste_R804 -- ELSE IF statement
  2183.  
  2184.    ffeste_R804(expr,expr_token,name_token);
  2185.  
  2186.    Make sure ffeste_kind_ identifies an IF block.  If not
  2187.    NULL, make sure name_token gives the correct name.  Implement the else
  2188.    of the IF block.  */
  2189.  
  2190. void
  2191. ffeste_R804 (ffebld expr)
  2192. {
  2193.   ffeste_check_simple_ ();
  2194.  
  2195. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2196.   fputs ("+ ELSE_IF (", stdout);
  2197.   ffebld_dump (expr);
  2198.   fputs (")\n", stdout);
  2199. #else
  2200. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2201.   ffeste_emit_line_note_ ();
  2202.   ffecom_push_calltemps ();
  2203.  
  2204.   expand_start_elseif (ffecom_truth_value (ffecom_expr (expr)));
  2205.  
  2206.   ffecom_pop_calltemps ();
  2207.   clear_momentary ();
  2208. #endif
  2209. #endif
  2210. }
  2211.  
  2212. /* ffeste_R805 -- ELSE statement
  2213.  
  2214.    ffeste_R805(name_token);
  2215.  
  2216.    Make sure ffeste_kind_ identifies an IF block.  If not
  2217.    NULL, make sure name_token gives the correct name.  Implement the ELSE
  2218.    of the IF block.  */
  2219.  
  2220. void
  2221. ffeste_R805 ()
  2222. {
  2223.   ffeste_check_simple_ ();
  2224.  
  2225. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2226.   fputs ("+ ELSE\n", stdout);
  2227. #else
  2228. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2229.   ffeste_emit_line_note_ ();
  2230.   expand_start_else ();
  2231.   clear_momentary ();
  2232. #endif
  2233. #endif
  2234. }
  2235.  
  2236. /* ffeste_R806 -- End an IF-THEN
  2237.  
  2238.    ffeste_R806(TRUE);  */
  2239.  
  2240. void
  2241. ffeste_R806 ()
  2242. {
  2243. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2244.   fputs ("+ END_IF_then\n", stdout);    /* Also see ffeste_shriek_if_. */
  2245. #else
  2246. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2247.   ffeste_emit_line_note_ ();
  2248.   expand_end_cond ();
  2249.   clear_momentary ();
  2250. #endif
  2251. #endif
  2252. }
  2253.  
  2254. /* ffeste_R807 -- Logical IF statement
  2255.  
  2256.    ffeste_R807(expr,expr_token);
  2257.  
  2258.    Make sure statement is valid here; implement.  */
  2259.  
  2260. void
  2261. ffeste_R807 (ffebld expr)
  2262. {
  2263.   ffeste_check_simple_ ();
  2264.  
  2265. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2266.   fputs ("+ IF_logical (", stdout);
  2267.   ffebld_dump (expr);
  2268.   fputs (")\n", stdout);
  2269. #else
  2270. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2271.   ffeste_emit_line_note_ ();
  2272.   ffecom_push_calltemps ();
  2273.  
  2274.   expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
  2275.  
  2276.   ffecom_pop_calltemps ();
  2277.   clear_momentary ();
  2278. #endif
  2279. #endif
  2280. }
  2281.  
  2282. /* ffeste_R809 -- SELECT CASE statement
  2283.  
  2284.    ffeste_R809(construct_name,expr,expr_token);
  2285.  
  2286.    Make sure statement is valid here; implement.  */
  2287.  
  2288. void
  2289. ffeste_R809 (ffestw block, ffebld expr)
  2290. {
  2291.   ffeste_check_simple_ ();
  2292.  
  2293. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2294.   fputs ("+ SELECT_CASE (", stdout);
  2295.   ffebld_dump (expr);
  2296.   fputs (")\n", stdout);
  2297. #else
  2298. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2299.   ffecom_push_calltemps ();
  2300.  
  2301.   {
  2302.     tree texpr;
  2303.  
  2304.     ffeste_emit_line_note_ ();
  2305.  
  2306.     if ((expr == NULL)
  2307.     || (ffeinfo_basictype (ffebld_info (expr))
  2308.         == FFEINFO_basictypeANY))
  2309.       {
  2310.     ffestw_set_select_texpr (block, error_mark_node);
  2311.     clear_momentary ();
  2312.       }
  2313.     else
  2314.       {
  2315.     texpr = ffecom_expr (expr);
  2316.     assert (ffeinfo_basictype (ffebld_info (expr))
  2317.         != FFEINFO_basictypeCHARACTER);
  2318.     expand_start_case (1, texpr, TREE_TYPE (texpr),
  2319.                "SELECT CASE statement");
  2320.     ffestw_set_select_texpr (block, texpr);
  2321.     ffestw_set_select_break (block, FALSE);
  2322.     push_momentary ();
  2323.       }
  2324.   }                /* ~~~handle character and special-case
  2325.                    character*1 */
  2326.  
  2327.   ffecom_pop_calltemps ();
  2328. #endif
  2329. #endif
  2330. }
  2331.  
  2332. /* ffeste_R810 -- CASE statement
  2333.  
  2334.    ffeste_R810(case_value_range_list,name);
  2335.  
  2336.    If casenum is 0, it's CASE DEFAULT.    Else it's the case ranges at
  2337.    the start of the first_stmt list in the select object at the top of
  2338.    the stack that match casenum.  */
  2339.  
  2340. void
  2341. ffeste_R810 (ffestw block, unsigned long casenum)
  2342. {
  2343.   ffestwSelect s = ffestw_select (block);
  2344.   ffestwCase c;
  2345.  
  2346.   ffeste_check_simple_ ();
  2347.  
  2348.   if (s->first_stmt == (ffestwCase) &s->first_rel)
  2349.     c = NULL;
  2350.   else
  2351.     c = s->first_stmt;
  2352.  
  2353. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2354.   if ((c == NULL) || (casenum != c->casenum))
  2355.     {
  2356.       if (casenum == 0)        /* Intentional CASE DEFAULT. */
  2357.     fputs ("+ CASE_DEFAULT", stdout);
  2358.     }
  2359.   else
  2360.     {
  2361.       bool comma = FALSE;
  2362.  
  2363.       fputs ("+ CASE (", stdout);
  2364.       do
  2365.     {
  2366.       if (comma)
  2367.         fputc (',', stdout);
  2368.       else
  2369.         comma = TRUE;
  2370.       if (c->low != NULL)
  2371.         ffebld_constant_dump (c->low);
  2372.       if (c->low != c->high)
  2373.         {
  2374.           fputc (':', stdout);
  2375.           if (c->high != NULL)
  2376.         ffebld_constant_dump (c->high);
  2377.         }
  2378.       c = c->next_stmt;
  2379.       /* Unlink prev.  */
  2380.       c->previous_stmt->previous_stmt->next_stmt = c;
  2381.       c->previous_stmt = c->previous_stmt->previous_stmt;
  2382.     }
  2383.       while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
  2384.       fputc (')', stdout);
  2385.     }
  2386.  
  2387.   fputc ('\n', stdout);
  2388. #else
  2389. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2390.   {
  2391.     tree texprlow;
  2392.     tree texprhigh;
  2393.     tree tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
  2394.     int pushok;
  2395.     tree duplicate;
  2396.  
  2397.     ffeste_emit_line_note_ ();
  2398.  
  2399.     if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
  2400.       {
  2401.     clear_momentary ();
  2402.     return;
  2403.       }
  2404.  
  2405.     if (ffestw_select_break (block))
  2406.       expand_exit_something ();
  2407.     else
  2408.       ffestw_set_select_break (block, TRUE);
  2409.  
  2410.     if ((c == NULL) || (casenum != c->casenum))
  2411.       {
  2412.     if (casenum == 0)    /* Intentional CASE DEFAULT. */
  2413.       {
  2414.         pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
  2415.         assert (pushok == 0);
  2416.       }
  2417.       }
  2418.     else
  2419.       do
  2420.     {
  2421.       texprlow = (c->low == NULL) ? NULL_TREE
  2422.         : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
  2423.                s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
  2424.       if (c->low != c->high)
  2425.         {
  2426.           texprhigh = (c->high == NULL) ? NULL_TREE
  2427.         : ffecom_constantunion (&ffebld_constant_union (c->high),
  2428.           s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
  2429.           pushok = pushcase_range (texprlow, texprhigh, convert,
  2430.                        tlabel, &duplicate);
  2431.         }
  2432.       else
  2433.         pushok = pushcase (texprlow, convert, tlabel, &duplicate);
  2434.       assert (pushok == 0);
  2435.       c = c->next_stmt;
  2436.       /* Unlink prev.  */
  2437.       c->previous_stmt->previous_stmt->next_stmt = c;
  2438.       c->previous_stmt = c->previous_stmt->previous_stmt;
  2439.     }
  2440.       while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
  2441.  
  2442.     clear_momentary ();
  2443.   }                /* ~~~handle character, character*1 */
  2444. #endif
  2445. #endif
  2446. }
  2447.  
  2448. /* ffeste_R811 -- End a SELECT
  2449.  
  2450.    ffeste_R811(TRUE);  */
  2451.  
  2452. void
  2453. ffeste_R811 (ffestw block)
  2454. {
  2455. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2456.   fputs ("+ END_SELECT\n", stdout);
  2457. #else
  2458. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2459.   ffeste_emit_line_note_ ();
  2460.  
  2461.   if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
  2462.     {
  2463.       clear_momentary ();
  2464.       return;
  2465.     }
  2466.  
  2467.   expand_end_case (ffestw_select_texpr (block));
  2468.   pop_momentary ();
  2469.   clear_momentary ();        /* ~~~handle character and character*1 */
  2470. #endif
  2471. #endif
  2472. }
  2473.  
  2474. /* Iterative DO statement.  */
  2475.  
  2476. void
  2477. ffeste_R819A (ffestw block, ffelab label, ffebld var,
  2478.           ffebld start, ffelexToken start_token,
  2479.           ffebld end, ffelexToken end_token,
  2480.           ffebld incr, ffelexToken incr_token)
  2481. {
  2482.   ffeste_check_simple_ ();
  2483.  
  2484. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2485.   if ((ffebld_op (incr) == FFEBLD_opCONTER)
  2486.       && (ffebld_constant_is_zero (ffebld_conter (incr))))
  2487.     {
  2488.       ffebad_start (FFEBAD_DO_STEP_ZERO);
  2489.       ffebad_here (0, ffelex_token_where_line (incr_token),
  2490.            ffelex_token_where_column (incr_token));
  2491.       ffebad_string ("Iterative DO loop");
  2492.       ffebad_finish ();
  2493.       /* Don't bother replacing it with 1 yet.  */
  2494.     }
  2495.  
  2496.   if (label == NULL)
  2497.     fputs ("+ DO_iterative_nonlabeled (", stdout);
  2498.   else
  2499.     fprintf (stdout, "+ DO_iterative_labeled %lu (", ffelab_value (label));
  2500.   ffebld_dump (var);
  2501.   fputc ('=', stdout);
  2502.   ffebld_dump (start);
  2503.   fputc (',', stdout);
  2504.   ffebld_dump (end);
  2505.   fputc (',', stdout);
  2506.   ffebld_dump (incr);
  2507.   fputs (")\n", stdout);
  2508. #else
  2509. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2510.   {
  2511.     ffeste_emit_line_note_ ();
  2512.     ffecom_push_calltemps ();
  2513.  
  2514.     /* Start the DO loop.  */
  2515.  
  2516.     ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
  2517.               var,
  2518.               start, start_token,
  2519.               end, end_token,
  2520.               incr, incr_token,
  2521.               "Iterative DO loop");
  2522.  
  2523.     ffecom_pop_calltemps ();
  2524.   }
  2525. #endif
  2526. #endif
  2527. }
  2528.  
  2529. /* ffeste_R819B -- DO WHILE statement
  2530.  
  2531.    ffeste_R819B(construct_name,label_token,expr,expr_token);
  2532.  
  2533.    Make sure statement is valid here; implement.  */
  2534.  
  2535. void
  2536. ffeste_R819B (ffestw block, ffelab label, ffebld expr)
  2537. {
  2538.   ffeste_check_simple_ ();
  2539.  
  2540. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2541.   if (label == NULL)
  2542.     fputs ("+ DO_WHILE_nonlabeled (", stdout);
  2543.   else
  2544.     fprintf (stdout, "+ DO_WHILE_labeled %lu (", ffelab_value (label));
  2545.   ffebld_dump (expr);
  2546.   fputs (")\n", stdout);
  2547. #else
  2548. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2549.   {
  2550.     ffeste_emit_line_note_ ();
  2551.     ffecom_push_calltemps ();
  2552.  
  2553.     ffestw_set_do_hook (block, expand_start_loop (1));
  2554.     ffestw_set_do_tvar (block, 0);    /* Means DO WHILE vs. iter DO. */
  2555.     if (expr != NULL)
  2556.       expand_exit_loop_if_false (0, ffecom_truth_value (ffecom_expr (expr)));
  2557.  
  2558.     ffecom_pop_calltemps ();
  2559.     clear_momentary ();
  2560.   }
  2561. #endif
  2562. #endif
  2563. }
  2564.  
  2565. /* ffeste_R825 -- END DO statement
  2566.  
  2567.    ffeste_R825(name_token);
  2568.  
  2569.    Make sure ffeste_kind_ identifies a DO block.  If not
  2570.    NULL, make sure name_token gives the correct name.  Do whatever
  2571.    is specific to seeing END DO with a DO-target label definition on it,
  2572.    where the END DO is really treated as a CONTINUE (i.e. generate th
  2573.    same code you would for CONTINUE).  ffeste_do handles the actual
  2574.    generation of end-loop code.     */
  2575.  
  2576. void
  2577. ffeste_R825 ()
  2578. {
  2579.   ffeste_check_simple_ ();
  2580.  
  2581. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2582.   fputs ("+ END_DO_sugar\n", stdout);
  2583. #else
  2584. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2585.   ffeste_emit_line_note_ ();
  2586.   emit_nop ();
  2587. #endif
  2588. #endif
  2589. }
  2590.  
  2591. /* ffeste_R834 -- CYCLE statement
  2592.  
  2593.    ffeste_R834(name_token);
  2594.  
  2595.    Handle a CYCLE within a loop.  */
  2596.  
  2597. void
  2598. ffeste_R834 (ffestw block)
  2599. {
  2600.   ffeste_check_simple_ ();
  2601.  
  2602. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2603.   fprintf (stdout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
  2604. #else
  2605. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2606.   ffeste_emit_line_note_ ();
  2607.   expand_continue_loop (ffestw_do_hook (block));
  2608.   clear_momentary ();
  2609. #endif
  2610. #endif
  2611. }
  2612.  
  2613. /* ffeste_R835 -- EXIT statement
  2614.  
  2615.    ffeste_R835(name_token);
  2616.  
  2617.    Handle a EXIT within a loop.     */
  2618.  
  2619. void
  2620. ffeste_R835 (ffestw block)
  2621. {
  2622.   ffeste_check_simple_ ();
  2623.  
  2624. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2625.   fprintf (stdout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
  2626. #else
  2627. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2628.   ffeste_emit_line_note_ ();
  2629.   expand_exit_loop (ffestw_do_hook (block));
  2630.   clear_momentary ();
  2631. #endif
  2632. #endif
  2633. }
  2634.  
  2635. /* ffeste_R836 -- GOTO statement
  2636.  
  2637.    ffeste_R836(label);
  2638.  
  2639.    Make sure label_token identifies a valid label for a GOTO.  Update
  2640.    that label's info to indicate it is the target of a GOTO.  */
  2641.  
  2642. void
  2643. ffeste_R836 (ffelab label)
  2644. {
  2645.   ffeste_check_simple_ ();
  2646.  
  2647. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2648.   fprintf (stdout, "+ GOTO %lu\n", ffelab_value (label));
  2649. #else
  2650. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2651.   {
  2652.     tree glabel;
  2653.  
  2654.     ffeste_emit_line_note_ ();
  2655.     glabel = ffecom_lookup_label (label);
  2656.     if ((glabel != NULL_TREE)
  2657.     && (TREE_CODE (glabel) != ERROR_MARK))
  2658.       {
  2659.     TREE_USED (glabel) = 1;
  2660.     expand_goto (glabel);
  2661.     clear_momentary ();
  2662.       }
  2663.   }
  2664. #endif
  2665. #endif
  2666. }
  2667.  
  2668. /* ffeste_R837 -- Computed GOTO statement
  2669.  
  2670.    ffeste_R837(labels,count,expr);
  2671.  
  2672.    Make sure label_list identifies valid labels for a GOTO.  Update
  2673.    each label's info to indicate it is the target of a GOTO.  */
  2674.  
  2675. void
  2676. ffeste_R837 (ffelab *labels, int count, ffebld expr)
  2677. {
  2678.   int i;
  2679.  
  2680.   ffeste_check_simple_ ();
  2681.  
  2682. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2683.   fputs ("+ CGOTO (", stdout);
  2684.   for (i = 0; i < count; ++i)
  2685.     {
  2686.       if (i != 0)
  2687.     fputc (',', stdout);
  2688.       fprintf (stdout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
  2689.     }
  2690.   fputs ("),", stdout);
  2691.   ffebld_dump (expr);
  2692.   fputc ('\n', stdout);
  2693. #else
  2694. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2695.   {
  2696.     tree texpr;
  2697.     tree value;
  2698.     tree tlabel;
  2699.     int pushok;
  2700.     tree duplicate;
  2701.  
  2702.     ffeste_emit_line_note_ ();
  2703.     ffecom_push_calltemps ();
  2704.  
  2705.     texpr = ffecom_expr (expr);
  2706.     expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
  2707.     push_momentary ();        /* In case of lots of labels, keep clearing
  2708.                    them out. */
  2709.     for (i = 0; i < count; ++i)
  2710.       {
  2711.     value = build_int_2 (i + 1, 0);
  2712.     tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
  2713.  
  2714.     pushok = pushcase (value, convert, tlabel, &duplicate);
  2715.     assert (pushok == 0);
  2716.     tlabel = ffecom_lookup_label (labels[i]);
  2717.     if ((tlabel == NULL_TREE)
  2718.         || (TREE_CODE (tlabel) == ERROR_MARK))
  2719.       continue;
  2720.     TREE_USED (tlabel) = 1;
  2721.     expand_goto (tlabel);
  2722.     clear_momentary ();
  2723.       }
  2724.     pop_momentary ();
  2725.     expand_end_case (texpr);
  2726.  
  2727.     ffecom_pop_calltemps ();
  2728.     clear_momentary ();
  2729.   }
  2730. #endif
  2731. #endif
  2732. }
  2733.  
  2734. /* ffeste_R838 -- ASSIGN statement
  2735.  
  2736.    ffeste_R838(label_token,target_variable,target_token);
  2737.  
  2738.    Make sure label_token identifies a valid label for an assignment.  Update
  2739.    that label's info to indicate it is the source of an assignment.  Update
  2740.    target_variable's info to indicate it is the target the assignment of that
  2741.    label.  */
  2742.  
  2743. void
  2744. ffeste_R838 (ffelab label, ffebld target)
  2745. {
  2746.   ffeste_check_simple_ ();
  2747.  
  2748. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2749.   fprintf (stdout, "+ ASSIGN %lu TO ", ffelab_value (label));
  2750.   ffebld_dump (target);
  2751.   fputc ('\n', stdout);
  2752. #else
  2753. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2754.   {
  2755.     tree expr_tree;
  2756.     tree label_tree;
  2757.     tree target_tree;
  2758.  
  2759.     ffeste_emit_line_note_ ();
  2760.     ffecom_push_calltemps ();
  2761.  
  2762.     label_tree = ffecom_lookup_label (label);
  2763.     if ((label_tree != NULL_TREE)
  2764.     && (TREE_CODE (label_tree) != ERROR_MARK))
  2765.       {
  2766.     label_tree = ffecom_1 (ADDR_EXPR,
  2767.                    build_pointer_type (void_type_node),
  2768.                    label_tree);
  2769.     TREE_CONSTANT (label_tree) = 1;
  2770.     target_tree = ffecom_expr_assign_w (target);
  2771.     if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
  2772.         < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
  2773.       error ("Cannot safely ASSIGN to an target narrower than a\
  2774.  label-pointer");
  2775.     label_tree = convert (TREE_TYPE (target_tree), label_tree);
  2776.     expr_tree = ffecom_modify (void_type_node,
  2777.                    target_tree,
  2778.                    label_tree);
  2779.     expand_expr_stmt (expr_tree);
  2780.     clear_momentary ();
  2781.       }
  2782.  
  2783.     ffecom_pop_calltemps ();
  2784.   }
  2785. #endif
  2786. #endif
  2787. }
  2788.  
  2789. /* ffeste_R839 -- Assigned GOTO statement
  2790.  
  2791.    ffeste_R839(target,target_token,label_list);
  2792.  
  2793.    Make sure label_list identifies valid labels for a GOTO.  Update
  2794.    each label's info to indicate it is the target of a GOTO.  */
  2795.  
  2796. void
  2797. ffeste_R839 (ffebld target)
  2798. {
  2799.   ffeste_check_simple_ ();
  2800.  
  2801. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2802.   fputs ("+ AGOTO ", stdout);
  2803.   ffebld_dump (target);
  2804.   fputc ('\n', stdout);
  2805. #else
  2806. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2807.   {
  2808.     tree t;
  2809.  
  2810.     ffeste_emit_line_note_ ();
  2811.     ffecom_push_calltemps ();
  2812.  
  2813.     t = ffecom_expr_assign (target);
  2814.     if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
  2815.     < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
  2816.       error ("Cannot safely GOTO an expression narrower than a pointer");
  2817.     expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
  2818.  
  2819.     ffecom_pop_calltemps ();
  2820.     clear_momentary ();
  2821.   }
  2822. #endif
  2823. #endif
  2824. }
  2825.  
  2826. /* ffeste_R840 -- Arithmetic IF statement
  2827.  
  2828.    ffeste_R840(expr,expr_token,neg,zero,pos);
  2829.  
  2830.    Make sure the labels are valid; implement.  */
  2831.  
  2832. void
  2833. ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
  2834. {
  2835.   ffeste_check_simple_ ();
  2836.  
  2837. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2838.   fputs ("+ IF_arithmetic (", stdout);
  2839.   ffebld_dump (expr);
  2840.   fprintf (stdout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
  2841.        ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
  2842. #else
  2843. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2844.   {
  2845.     tree gneg = ffecom_lookup_label (neg);
  2846.     tree gzero = ffecom_lookup_label (zero);
  2847.     tree gpos = ffecom_lookup_label (pos);
  2848.     tree texpr;
  2849.  
  2850.     if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
  2851.       return;
  2852.     if ((TREE_CODE (gneg) == ERROR_MARK)
  2853.     || (TREE_CODE (gzero) == ERROR_MARK)
  2854.     || (TREE_CODE (gpos) == ERROR_MARK))
  2855.       return;
  2856.  
  2857.     ffecom_push_calltemps ();
  2858.  
  2859.     if (neg == zero)
  2860.       if (neg == pos)
  2861.     expand_goto (gzero);
  2862.       else
  2863.     {            /* IF (expr.LE.0) THEN GOTO neg/zero ELSE
  2864.                    GOTO pos. */
  2865.       texpr = ffecom_expr (expr);
  2866.       texpr = ffecom_2 (LE_EXPR, integer_type_node,
  2867.                 texpr,
  2868.                 convert (TREE_TYPE (texpr),
  2869.                      integer_zero_node));
  2870.       expand_start_cond (ffecom_truth_value (texpr), 0);
  2871.       expand_goto (gzero);
  2872.       expand_start_else ();
  2873.       expand_goto (gpos);
  2874.       expand_end_cond ();
  2875.     }
  2876.     else if (neg == pos)
  2877.       {                /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO
  2878.                    zero. */
  2879.     texpr = ffecom_expr (expr);
  2880.     texpr = ffecom_2 (NE_EXPR, integer_type_node,
  2881.               texpr,
  2882.               convert (TREE_TYPE (texpr),
  2883.                    integer_zero_node));
  2884.     expand_start_cond (ffecom_truth_value (texpr), 0);
  2885.     expand_goto (gneg);
  2886.     expand_start_else ();
  2887.     expand_goto (gzero);
  2888.     expand_end_cond ();
  2889.       }
  2890.     else if (zero == pos)
  2891.       {                /* IF (expr.GE.0) THEN GOTO zero/pos ELSE
  2892.                    GOTO neg. */
  2893.     texpr = ffecom_expr (expr);
  2894.     texpr = ffecom_2 (GE_EXPR, integer_type_node,
  2895.               texpr,
  2896.               convert (TREE_TYPE (texpr),
  2897.                    integer_zero_node));
  2898.     expand_start_cond (ffecom_truth_value (texpr), 0);
  2899.     expand_goto (gzero);
  2900.     expand_start_else ();
  2901.     expand_goto (gneg);
  2902.     expand_end_cond ();
  2903.       }
  2904.     else
  2905.       {                /* Use a SAVE_EXPR in combo with:
  2906.                    IF (expr.LT.0) THEN GOTO neg
  2907.                    ELSEIF (expr.GT.0) THEN GOTO pos
  2908.                    ELSE GOTO zero. */
  2909.     tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
  2910.  
  2911.     texpr = ffecom_2 (LT_EXPR, integer_type_node,
  2912.               expr_saved,
  2913.               convert (TREE_TYPE (expr_saved),
  2914.                    integer_zero_node));
  2915.     expand_start_cond (ffecom_truth_value (texpr), 0);
  2916.     expand_goto (gneg);
  2917.     texpr = ffecom_2 (GT_EXPR, integer_type_node,
  2918.               expr_saved,
  2919.               convert (TREE_TYPE (expr_saved),
  2920.                    integer_zero_node));
  2921.     expand_start_elseif (ffecom_truth_value (texpr));
  2922.     expand_goto (gpos);
  2923.     expand_start_else ();
  2924.     expand_goto (gzero);
  2925.     expand_end_cond ();
  2926.       }
  2927.     ffeste_emit_line_note_ ();
  2928.  
  2929.     ffecom_pop_calltemps ();
  2930.     clear_momentary ();
  2931.   }
  2932. #endif
  2933. #endif
  2934. }
  2935.  
  2936. /* ffeste_R841 -- CONTINUE statement
  2937.  
  2938.    ffeste_R841();  */
  2939.  
  2940. void
  2941. ffeste_R841 ()
  2942. {
  2943.   ffeste_check_simple_ ();
  2944.  
  2945. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2946.   fputs ("+ CONTINUE\n", stdout);
  2947. #else
  2948. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2949.   ffeste_emit_line_note_ ();
  2950.   emit_nop ();
  2951. #endif
  2952. #endif
  2953. }
  2954.  
  2955. /* ffeste_R842 -- STOP statement
  2956.  
  2957.    ffeste_R842(expr);  */
  2958.  
  2959. void
  2960. ffeste_R842 (ffebld expr)
  2961. {
  2962.   ffeste_check_simple_ ();
  2963.  
  2964. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  2965.   if (expr == NULL)
  2966.     {
  2967.       fputs ("+ STOP\n", stdout);
  2968.     }
  2969.   else
  2970.     {
  2971.       fputs ("+ STOP_coded ", stdout);
  2972.       ffebld_dump (expr);
  2973.       fputc ('\n', stdout);
  2974.     }
  2975. #else
  2976. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2977.   {
  2978.     tree callit;
  2979.     ffelexToken msg;
  2980.  
  2981.     ffeste_emit_line_note_ ();
  2982.     if ((expr == NULL)
  2983.     || (ffeinfo_basictype (ffebld_info (expr))
  2984.         == FFEINFO_basictypeANY))
  2985.       {
  2986.     msg = ffelex_token_new_character ("", ffelex_token_where_line
  2987.                    (ffesta_tokens[0]), ffelex_token_where_column
  2988.                       (ffesta_tokens[0]));
  2989.     expr = ffebld_new_conter (ffebld_constant_new_characterdefault
  2990.                   (msg));
  2991.     ffelex_token_kill (msg);
  2992.     ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
  2993.             FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
  2994.                         FFEINFO_whereCONSTANT, 0));
  2995.       }
  2996.     else if (ffeinfo_basictype (ffebld_info (expr))
  2997.          == FFEINFO_basictypeINTEGER)
  2998.       {
  2999.     char num[50];
  3000.  
  3001.     assert (ffebld_op (expr) == FFEBLD_opCONTER);
  3002.     assert (ffeinfo_kindtype (ffebld_info (expr))
  3003.         == FFEINFO_kindtypeINTEGERDEFAULT);
  3004.     sprintf (num, "%" ffetargetIntegerDefault_f "d",
  3005.          ffebld_constant_integer1 (ffebld_conter (expr)));
  3006.     msg = ffelex_token_new_character (num, ffelex_token_where_line
  3007.                    (ffesta_tokens[0]), ffelex_token_where_column
  3008.                       (ffesta_tokens[0]));
  3009.     expr = ffebld_new_conter (ffebld_constant_new_characterdefault
  3010.                   (msg));
  3011.     ffelex_token_kill (msg);
  3012.     ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
  3013.             FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
  3014.                         FFEINFO_whereCONSTANT, 0));
  3015.       }
  3016.     else
  3017.       {
  3018.     assert (ffeinfo_basictype (ffebld_info (expr))
  3019.         == FFEINFO_basictypeCHARACTER);
  3020.     assert (ffebld_op (expr) == FFEBLD_opCONTER);
  3021.     assert (ffeinfo_kindtype (ffebld_info (expr))
  3022.         == FFEINFO_kindtypeCHARACTERDEFAULT);
  3023.       }
  3024.  
  3025.     ffecom_push_calltemps ();
  3026.     callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
  3027.             ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
  3028.     ffecom_pop_calltemps ();
  3029.     TREE_SIDE_EFFECTS (callit) = 1;
  3030.     expand_expr_stmt (callit);
  3031.     clear_momentary ();
  3032.   }
  3033. #endif
  3034. #endif
  3035. }
  3036.  
  3037. /* ffeste_R843 -- PAUSE statement
  3038.  
  3039.    ffeste_R843(expr,expr_token);
  3040.  
  3041.    Make sure statement is valid here; implement.  expr and expr_token are
  3042.    both NULL if there was no expression.  */
  3043.  
  3044. void
  3045. ffeste_R843 (ffebld expr)
  3046. {
  3047.   ffeste_check_simple_ ();
  3048.  
  3049. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3050.   if (expr == NULL)
  3051.     {
  3052.       fputs ("+ PAUSE\n", stdout);
  3053.     }
  3054.   else
  3055.     {
  3056.       fputs ("+ PAUSE_coded ", stdout);
  3057.       ffebld_dump (expr);
  3058.       fputc ('\n', stdout);
  3059.     }
  3060. #else
  3061. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3062.   {
  3063.     tree callit;
  3064.     ffelexToken msg;
  3065.  
  3066.     ffeste_emit_line_note_ ();
  3067.     if ((expr == NULL)
  3068.     || (ffeinfo_basictype (ffebld_info (expr))
  3069.         == FFEINFO_basictypeANY))
  3070.       {
  3071.     msg = ffelex_token_new_character ("", ffelex_token_where_line
  3072.                    (ffesta_tokens[0]), ffelex_token_where_column
  3073.                       (ffesta_tokens[0]));
  3074.     expr = ffebld_new_conter (ffebld_constant_new_characterdefault
  3075.                   (msg));
  3076.     ffelex_token_kill (msg);
  3077.     ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
  3078.             FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
  3079.                         FFEINFO_whereCONSTANT, 0));
  3080.       }
  3081.     else if (ffeinfo_basictype (ffebld_info (expr))
  3082.          == FFEINFO_basictypeINTEGER)
  3083.       {
  3084.     char num[50];
  3085.  
  3086.     assert (ffebld_op (expr) == FFEBLD_opCONTER);
  3087.     assert (ffeinfo_kindtype (ffebld_info (expr))
  3088.         == FFEINFO_kindtypeINTEGERDEFAULT);
  3089.     sprintf (num, "%" ffetargetIntegerDefault_f "d",
  3090.          ffebld_constant_integer1 (ffebld_conter (expr)));
  3091.     msg = ffelex_token_new_character (num, ffelex_token_where_line
  3092.                    (ffesta_tokens[0]), ffelex_token_where_column
  3093.                       (ffesta_tokens[0]));
  3094.     expr = ffebld_new_conter (ffebld_constant_new_characterdefault
  3095.                   (msg));
  3096.     ffelex_token_kill (msg);
  3097.     ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
  3098.             FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
  3099.                         FFEINFO_whereCONSTANT, 0));
  3100.       }
  3101.     else
  3102.       {
  3103.     assert (ffeinfo_basictype (ffebld_info (expr))
  3104.         == FFEINFO_basictypeCHARACTER);
  3105.     assert (ffebld_op (expr) == FFEBLD_opCONTER);
  3106.     assert (ffeinfo_kindtype (ffebld_info (expr))
  3107.         == FFEINFO_kindtypeCHARACTERDEFAULT);
  3108.       }
  3109.  
  3110.     ffecom_push_calltemps ();
  3111.     callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
  3112.             ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
  3113.     ffecom_pop_calltemps ();
  3114.     TREE_SIDE_EFFECTS (callit) = 1;
  3115.     expand_expr_stmt (callit);
  3116.     clear_momentary ();
  3117.   }
  3118. #if 0                /* Old approach for phantom g77 run-time
  3119.                    library. */
  3120.   {
  3121.     tree callit;
  3122.  
  3123.     ffeste_emit_line_note_ ();
  3124.     if (expr == NULL)
  3125.       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE);
  3126.     else if (ffeinfo_basictype (ffebld_info (expr))
  3127.          == FFEINFO_basictypeINTEGER)
  3128.       {
  3129.     ffecom_push_calltemps ();
  3130.     callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
  3131.             ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
  3132.     ffecom_pop_calltemps ();
  3133.       }
  3134.     else
  3135.       {
  3136.     if (ffeinfo_basictype (ffebld_info (expr))
  3137.         != FFEINFO_basictypeCHARACTER)
  3138.       break;
  3139.     ffecom_push_calltemps ();
  3140.     callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
  3141.             ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
  3142.     ffecom_pop_calltemps ();
  3143.       }
  3144.     TREE_SIDE_EFFECTS (callit) = 1;
  3145.     expand_expr_stmt (callit);
  3146.     clear_momentary ();
  3147.   }
  3148. #endif
  3149. #endif
  3150. #endif
  3151. }
  3152.  
  3153. /* ffeste_R904 -- OPEN statement
  3154.  
  3155.    ffeste_R904();
  3156.  
  3157.    Make sure an OPEN is valid in the current context, and implement it.     */
  3158.  
  3159. void
  3160. ffeste_R904 (ffestpOpenStmt *info)
  3161. {
  3162.   ffeste_check_simple_ ();
  3163.  
  3164. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3165.   fputs ("+ OPEN (", stdout);
  3166.   ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
  3167.   ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
  3168.   ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
  3169.   ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
  3170.   ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
  3171.   ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
  3172.   ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
  3173.   ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
  3174.   ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
  3175.   ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
  3176.   ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
  3177.   ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
  3178.   ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
  3179.   ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
  3180.   ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
  3181.   ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
  3182.   ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
  3183.   ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
  3184.   ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
  3185.   ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
  3186.   ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
  3187.   ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
  3188.   ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
  3189.   ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
  3190.   ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
  3191.   ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
  3192.   ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
  3193.   ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
  3194.   ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
  3195.   fputs (")\n", stdout);
  3196. #else
  3197. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3198.   {
  3199.     tree args;
  3200.     bool iostat;
  3201.     bool errl;
  3202.  
  3203. #define specified(something) (info->open_spec[something].kw_or_val_present)
  3204.  
  3205.     ffeste_emit_line_note_ ();
  3206.  
  3207.     iostat = specified (FFESTP_openixIOSTAT);
  3208.     errl = specified (FFESTP_openixERR);
  3209.  
  3210.     ffecom_push_calltemps ();
  3211.  
  3212.     args = ffeste_io_olist_ (errl || iostat,
  3213.                  info->open_spec[FFESTP_openixUNIT].u.expr,
  3214.                  &info->open_spec[FFESTP_openixFILE],
  3215.                  &info->open_spec[FFESTP_openixSTATUS],
  3216.                  &info->open_spec[FFESTP_openixACCESS],
  3217.                  &info->open_spec[FFESTP_openixFORM],
  3218.                  &info->open_spec[FFESTP_openixRECL],
  3219.                  &info->open_spec[FFESTP_openixBLANK]);
  3220.  
  3221.     if (errl)
  3222.       {
  3223.     ffeste_io_err_
  3224.       = ffeste_io_abort_
  3225.       = ffecom_lookup_label
  3226.       (info->open_spec[FFESTP_openixERR].u.label);
  3227.     ffeste_io_abort_is_temp_ = FALSE;
  3228.       }
  3229.     else
  3230.       {
  3231.     ffeste_io_err_ = NULL_TREE;
  3232.  
  3233.     if ((ffeste_io_abort_is_temp_ = iostat))
  3234.       ffeste_io_abort_ = ffecom_temp_label ();
  3235.     else
  3236.       ffeste_io_abort_ = NULL_TREE;
  3237.       }
  3238.  
  3239.     if (iostat)
  3240.       {                /* IOSTAT= */
  3241.     ffeste_io_iostat_is_temp_ = FALSE;
  3242.     ffeste_io_iostat_ = ffecom_expr
  3243.       (info->open_spec[FFESTP_openixIOSTAT].u.expr);
  3244.       }
  3245.     else if (ffeste_io_abort_ != NULL_TREE)
  3246.       {                /* no IOSTAT= but ERR= */
  3247.     ffeste_io_iostat_is_temp_ = TRUE;
  3248.     ffeste_io_iostat_
  3249.       = ffecom_push_tempvar (ffecom_integer_type_node,
  3250.                  FFETARGET_charactersizeNONE, -1, FALSE);
  3251.       }
  3252.     else
  3253.       {                /* no IOSTAT=, or ERR= */
  3254.     ffeste_io_iostat_is_temp_ = FALSE;
  3255.     ffeste_io_iostat_ = NULL_TREE;
  3256.       }
  3257.  
  3258.     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  3259.        label, since we're gonna fall through to there anyway. */
  3260.  
  3261.     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args),
  3262.           !ffeste_io_abort_is_temp_ && (ffeste_io_abort_ != NULL_TREE));
  3263.  
  3264.     /* If we've got a temp label, generate its code here. */
  3265.  
  3266.     if (ffeste_io_abort_is_temp_)
  3267.       {
  3268.     DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  3269.     emit_nop ();
  3270.     expand_label (ffeste_io_abort_);
  3271.  
  3272.     assert (ffeste_io_err_ == NULL_TREE);
  3273.       }
  3274.  
  3275.     /* If we've got a temp iostat, pop the temp. */
  3276.  
  3277.     if (ffeste_io_iostat_is_temp_)
  3278.       ffecom_pop_tempvar (ffeste_io_iostat_);
  3279.  
  3280.     ffecom_pop_calltemps ();
  3281.  
  3282. #undef specified
  3283.   }
  3284.  
  3285.   clear_momentary ();
  3286. #endif
  3287. #endif
  3288. }
  3289.  
  3290. /* ffeste_R907 -- CLOSE statement
  3291.  
  3292.    ffeste_R907();
  3293.  
  3294.    Make sure a CLOSE is valid in the current context, and implement it.     */
  3295.  
  3296. void
  3297. ffeste_R907 (ffestpCloseStmt *info)
  3298. {
  3299.   ffeste_check_simple_ ();
  3300.  
  3301. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3302.   fputs ("+ CLOSE (", stdout);
  3303.   ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
  3304.   ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
  3305.   ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
  3306.   ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
  3307.   fputs (")\n", stdout);
  3308. #else
  3309. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3310.   {
  3311.     tree args;
  3312.     bool iostat;
  3313.     bool errl;
  3314.  
  3315. #define specified(something) (info->close_spec[something].kw_or_val_present)
  3316.  
  3317.     ffeste_emit_line_note_ ();
  3318.  
  3319.     iostat = specified (FFESTP_closeixIOSTAT);
  3320.     errl = specified (FFESTP_closeixERR);
  3321.  
  3322.     ffecom_push_calltemps ();
  3323.  
  3324.     args = ffeste_io_cllist_ (errl || iostat,
  3325.                   info->close_spec[FFESTP_closeixUNIT].u.expr,
  3326.                   &info->close_spec[FFESTP_closeixSTATUS]);
  3327.  
  3328.     if (errl)
  3329.       {
  3330.     ffeste_io_err_
  3331.       = ffeste_io_abort_
  3332.       = ffecom_lookup_label
  3333.       (info->close_spec[FFESTP_closeixERR].u.label);
  3334.     ffeste_io_abort_is_temp_ = FALSE;
  3335.       }
  3336.     else
  3337.       {
  3338.     ffeste_io_err_ = NULL_TREE;
  3339.  
  3340.     if ((ffeste_io_abort_is_temp_ = iostat))
  3341.       ffeste_io_abort_ = ffecom_temp_label ();
  3342.     else
  3343.       ffeste_io_abort_ = NULL_TREE;
  3344.       }
  3345.  
  3346.     if (iostat)
  3347.       {                /* IOSTAT= */
  3348.     ffeste_io_iostat_is_temp_ = FALSE;
  3349.     ffeste_io_iostat_ = ffecom_expr
  3350.       (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
  3351.       }
  3352.     else if (ffeste_io_abort_ != NULL_TREE)
  3353.       {                /* no IOSTAT= but ERR= */
  3354.     ffeste_io_iostat_is_temp_ = TRUE;
  3355.     ffeste_io_iostat_
  3356.       = ffecom_push_tempvar (ffecom_integer_type_node,
  3357.                  FFETARGET_charactersizeNONE, -1, FALSE);
  3358.       }
  3359.     else
  3360.       {                /* no IOSTAT=, or ERR= */
  3361.     ffeste_io_iostat_is_temp_ = FALSE;
  3362.     ffeste_io_iostat_ = NULL_TREE;
  3363.       }
  3364.  
  3365.     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  3366.        label, since we're gonna fall through to there anyway. */
  3367.  
  3368.     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args),
  3369.           !ffeste_io_abort_is_temp_ && (ffeste_io_abort_ != NULL_TREE));
  3370.  
  3371.     /* If we've got a temp label, generate its code here. */
  3372.  
  3373.     if (ffeste_io_abort_is_temp_)
  3374.       {
  3375.     DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  3376.     emit_nop ();
  3377.     expand_label (ffeste_io_abort_);
  3378.  
  3379.     assert (ffeste_io_err_ == NULL_TREE);
  3380.       }
  3381.  
  3382.     /* If we've got a temp iostat, pop the temp. */
  3383.  
  3384.     if (ffeste_io_iostat_is_temp_)
  3385.       ffecom_pop_tempvar (ffeste_io_iostat_);
  3386.  
  3387.     ffecom_pop_calltemps ();
  3388.  
  3389. #undef specified
  3390.   }
  3391.  
  3392.   clear_momentary ();
  3393. #endif
  3394. #endif
  3395. }
  3396.  
  3397. /* ffeste_R909_start -- READ(...) statement list begin
  3398.  
  3399.    ffeste_R909_start(FALSE);
  3400.  
  3401.    Verify that READ is valid here, and begin accepting items in the
  3402.    list.  */
  3403.  
  3404. void
  3405. ffeste_R909_start (ffestpReadStmt *info, bool only_format, ffestvUnit unit,
  3406.            ffestvFormat format, bool rec, bool key)
  3407. {
  3408.   ffeste_check_start_ ();
  3409.  
  3410. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3411.   switch (format)
  3412.     {
  3413.     case FFESTV_formatNONE:
  3414.       if (rec)
  3415.     fputs ("+ READ_ufdac", stdout);
  3416.       else if (key)
  3417.     fputs ("+ READ_ufidx", stdout);
  3418.       else
  3419.     fputs ("+ READ_ufseq", stdout);
  3420.       break;
  3421.  
  3422.     case FFESTV_formatLABEL:
  3423.     case FFESTV_formatCHAREXPR:
  3424.     case FFESTV_formatINTEXPR:
  3425.       if (rec)
  3426.     fputs ("+ READ_fmdac", stdout);
  3427.       else if (key)
  3428.     fputs ("+ READ_fmidx", stdout);
  3429.       else if (unit == FFESTV_unitCHAREXPR)
  3430.     fputs ("+ READ_fmint", stdout);
  3431.       else
  3432.     fputs ("+ READ_fmseq", stdout);
  3433.       break;
  3434.  
  3435.     case FFESTV_formatASTERISK:
  3436.       if (unit == FFESTV_unitCHAREXPR)
  3437.     fputs ("+ READ_lsint", stdout);
  3438.       else
  3439.     fputs ("+ READ_lsseq", stdout);
  3440.       break;
  3441.  
  3442.     case FFESTV_formatNAMELIST:
  3443.       fputs ("+ READ_nlseq", stdout);
  3444.       break;
  3445.  
  3446.     default:
  3447.       assert ("Unexpected kind of format item in R909 READ" == NULL);
  3448.     }
  3449.  
  3450.   if (only_format)
  3451.     {
  3452.       fputc (' ', stdout);
  3453.       ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
  3454.       fputc (' ', stdout);
  3455.  
  3456.       return;
  3457.     }
  3458.  
  3459.   fputs (" (", stdout);
  3460.   ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
  3461.   ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
  3462.   ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
  3463.   ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
  3464.   ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
  3465.   ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
  3466.   ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
  3467.   ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
  3468.   ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
  3469.   ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
  3470.   ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
  3471.   ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
  3472.   ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
  3473.   ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
  3474.   fputs (") ", stdout);
  3475. #else
  3476. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3477.  
  3478. #define specified(something) (info->read_spec[something].kw_or_val_present)
  3479.  
  3480.   ffeste_emit_line_note_ ();
  3481.  
  3482.   /* Do the real work. */
  3483.  
  3484.   {
  3485.     ffecomGfrt start;
  3486.     ffecomGfrt end;
  3487.     tree cilist;
  3488.     bool iostat;
  3489.     bool errl;
  3490.     bool endl;
  3491.  
  3492.     /* First determine the start, per-item, and end run-time functions to
  3493.        call.  The per-item function is picked by choosing an ffeste functio
  3494.        to call to handle a given item; it knows how to generate a call to the
  3495.        appropriate run-time function, and is called an "io driver".  It
  3496.        handles the implied-DO construct, for example. */
  3497.  
  3498.     switch (format)
  3499.       {
  3500.       case FFESTV_formatNONE:    /* no FMT= */
  3501.     ffeste_io_driver_ = ffeste_io_douio_;
  3502.     if (rec)
  3503.       start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
  3504. #if 0
  3505.     else if (key)
  3506.       start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
  3507. #endif
  3508.     else
  3509.       start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
  3510.     break;
  3511.  
  3512.       case FFESTV_formatLABEL:    /* FMT=10 */
  3513.       case FFESTV_formatCHAREXPR:    /* FMT='(I10)' */
  3514.       case FFESTV_formatINTEXPR:    /* FMT=I [after ASSIGN 10 TO I] */
  3515.     ffeste_io_driver_ = ffeste_io_dofio_;
  3516.     if (rec)
  3517.       start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
  3518. #if 0
  3519.     else if (key)
  3520.       start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
  3521. #endif
  3522.     else if (unit == FFESTV_unitCHAREXPR)
  3523.       start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
  3524.     else
  3525.       start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
  3526.     break;
  3527.  
  3528.       case FFESTV_formatASTERISK:    /* FMT=* */
  3529.     ffeste_io_driver_ = ffeste_io_dolio_;
  3530.     if (unit == FFESTV_unitCHAREXPR)
  3531.       start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
  3532.     else
  3533.       start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
  3534.     break;
  3535.  
  3536.       case FFESTV_formatNAMELIST:    /* FMT=FOO or NML=FOO [NAMELIST
  3537.                        /FOO/] */
  3538.     ffeste_io_driver_ = NULL;    /* No start or driver function. */
  3539.     start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
  3540.     break;
  3541.  
  3542.       default:
  3543.     assert ("Weird stuff" == NULL);
  3544.     start = FFECOM_gfrt, end = FFECOM_gfrt;
  3545.     break;
  3546.       }
  3547.     ffeste_io_endgfrt_ = end;
  3548.  
  3549.     iostat = specified (FFESTP_readixIOSTAT);
  3550.     errl = specified (FFESTP_readixERR);
  3551.     endl = specified (FFESTP_readixEND);
  3552.  
  3553.     ffecom_push_calltemps ();
  3554.  
  3555.     if (unit == FFESTV_unitCHAREXPR)
  3556.       {
  3557.     cilist = ffeste_io_icilist_ (errl || iostat,
  3558.                   info->read_spec[FFESTP_readixUNIT].u.expr,
  3559.                      endl || iostat, format,
  3560.                      &info->read_spec[FFESTP_readixFORMAT]);
  3561.       }
  3562.     else
  3563.       {
  3564.     cilist = ffeste_io_cilist_ (errl || iostat, unit,
  3565.                   info->read_spec[FFESTP_readixUNIT].u.expr,
  3566.                     5, endl || iostat, format,
  3567.                     &info->read_spec[FFESTP_readixFORMAT],
  3568.                     rec,
  3569.                   info->read_spec[FFESTP_readixREC].u.expr);
  3570.       }
  3571.  
  3572.     if (errl)
  3573.       {                /* ERR= */
  3574.     ffeste_io_err_
  3575.       = ffecom_lookup_label
  3576.       (info->read_spec[FFESTP_readixERR].u.label);
  3577.  
  3578.     if (endl)
  3579.       {            /* ERR= END= */
  3580.         ffeste_io_end_
  3581.           = ffecom_lookup_label
  3582.           (info->read_spec[FFESTP_readixEND].u.label);
  3583.         ffeste_io_abort_is_temp_ = TRUE;
  3584.         ffeste_io_abort_ = ffecom_temp_label ();
  3585.       }
  3586.     else
  3587.       {            /* ERR= but no END= */
  3588.         ffeste_io_end_ = NULL_TREE;
  3589.         if ((ffeste_io_abort_is_temp_ = iostat))
  3590.           ffeste_io_abort_ = ffecom_temp_label ();
  3591.         else
  3592.           ffeste_io_abort_ = ffeste_io_err_;
  3593.       }
  3594.       }
  3595.     else
  3596.       {                /* no ERR= */
  3597.     ffeste_io_err_ = NULL_TREE;
  3598.     if (endl)
  3599.       {            /* END= but no ERR= */
  3600.         ffeste_io_end_
  3601.           = ffecom_lookup_label
  3602.           (info->read_spec[FFESTP_readixEND].u.label);
  3603.         if ((ffeste_io_abort_is_temp_ = iostat))
  3604.           ffeste_io_abort_ = ffecom_temp_label ();
  3605.         else
  3606.           ffeste_io_abort_ = ffeste_io_end_;
  3607.       }
  3608.     else
  3609.       {            /* no ERR= or END= */
  3610.         ffeste_io_end_ = NULL_TREE;
  3611.         if ((ffeste_io_abort_is_temp_ = iostat))
  3612.           ffeste_io_abort_ = ffecom_temp_label ();
  3613.         else
  3614.           ffeste_io_abort_ = NULL_TREE;
  3615.       }
  3616.       }
  3617.  
  3618.     if (iostat)
  3619.       {                /* IOSTAT= */
  3620.     ffeste_io_iostat_is_temp_ = FALSE;
  3621.     ffeste_io_iostat_ = ffecom_expr
  3622.       (info->read_spec[FFESTP_readixIOSTAT].u.expr);
  3623.       }
  3624.     else if (ffeste_io_abort_ != NULL_TREE)
  3625.       {                /* no IOSTAT= but ERR= or END= or both */
  3626.     ffeste_io_iostat_is_temp_ = TRUE;
  3627.     ffeste_io_iostat_
  3628.       = ffecom_push_tempvar (ffecom_integer_type_node,
  3629.                  FFETARGET_charactersizeNONE, -1, FALSE);
  3630.       }
  3631.     else
  3632.       {                /* no IOSTAT=, ERR=, or END= */
  3633.     ffeste_io_iostat_is_temp_ = FALSE;
  3634.     ffeste_io_iostat_ = NULL_TREE;
  3635.       }
  3636.  
  3637.     /* If there is no end function, then there are no item functions (i.e.
  3638.        it's a NAMELIST), and vice versa by the way.  In this situation, don't
  3639.        generate the "if (iostat != 0) goto label;" if the label is temp abort
  3640.        label, since we're gonna fall through to there anyway.  */
  3641.  
  3642.     ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
  3643.              (ffeste_io_abort_ != NULL_TREE)
  3644.              && (!ffeste_io_abort_is_temp_
  3645.              || (end != FFECOM_gfrt)));
  3646.   }
  3647.  
  3648. #undef specified
  3649.  
  3650.   push_momentary ();
  3651. #endif
  3652. #endif
  3653. }
  3654.  
  3655. /* ffeste_R909_item -- READ statement i/o item
  3656.  
  3657.    ffeste_R909_item(expr,expr_token);
  3658.  
  3659.    Implement output-list expression.  */
  3660.  
  3661. void
  3662. ffeste_R909_item (ffebld expr, ffelexToken expr_token)
  3663. {
  3664.   ffeste_check_item_ ();
  3665.  
  3666. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3667.   ffebld_dump (expr);
  3668.   fputc (',', stdout);
  3669. #else
  3670. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3671.   if (expr == NULL)
  3672.     return;
  3673.   while (ffebld_op (expr) == FFEBLD_opPAREN)
  3674.     expr = ffebld_left (expr);    /* "READ *,(A)" -- really a bug in the user's
  3675.                    code, but I've been told lots of code does
  3676.                    this (blech)! */
  3677.   if (ffebld_op (expr) == FFEBLD_opANY)
  3678.     return;
  3679.   if (ffebld_op (expr) == FFEBLD_opIMPDO)
  3680.     ffeste_io_impdo_ (expr, expr_token);
  3681.   else
  3682.     ffeste_io_call_ ((*ffeste_io_driver_) (expr),
  3683.              (ffeste_io_abort_ != NULL_TREE));
  3684.   clear_momentary ();
  3685. #endif
  3686. #endif
  3687. }
  3688.  
  3689. /* ffeste_R909_finish -- READ statement list complete
  3690.  
  3691.    ffeste_R909_finish();
  3692.  
  3693.    Just wrap up any local activities.  */
  3694.  
  3695. void
  3696. ffeste_R909_finish ()
  3697. {
  3698.   ffeste_check_finish_ ();
  3699.  
  3700. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3701.   fputc ('\n', stdout);
  3702. #else
  3703. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3704.  
  3705.   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  3706.      label, since we're gonna fall through to there anyway. */
  3707.  
  3708.   /* SPECIAL CASE: for e_rsle and e_rsli, don't generate the check AND don't
  3709.      even let ffeste_io_call_ bother writing to IOSTAT=, since
  3710.      dmg@research.att.com claims that e_[rw]sl[ei] always return 0. */
  3711.  
  3712.   {
  3713.     tree iostat = ffeste_io_iostat_;
  3714.  
  3715.     if (ffeste_io_driver_ == ffeste_io_dolio_)
  3716.       ffeste_io_iostat_ = NULL_TREE;
  3717.  
  3718.     if (ffeste_io_endgfrt_ != FFECOM_gfrt)
  3719.       ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
  3720.                !ffeste_io_abort_is_temp_
  3721.                && (ffeste_io_abort_ != NULL_TREE)
  3722.                && (ffeste_io_driver_ != ffeste_io_dolio_));
  3723.  
  3724.     clear_momentary ();
  3725.     pop_momentary ();
  3726.  
  3727.     /* If we've got a temp label, generate its code here and have it fan out
  3728.        to the END= or ERR= label as appropriate. */
  3729.  
  3730.     if (ffeste_io_abort_is_temp_)
  3731.       {
  3732.     DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  3733.     emit_nop ();
  3734.     expand_label (ffeste_io_abort_);
  3735.  
  3736.     /* if (iostat<0) goto end_label; */
  3737.  
  3738.     if ((ffeste_io_end_ != NULL_TREE)
  3739.         && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
  3740.       {
  3741.         expand_start_cond (ffecom_truth_value
  3742.                    (ffecom_2 (LT_EXPR, integer_type_node,
  3743.                       iostat,
  3744.                       ffecom_integer_zero_node)),
  3745.                    0);
  3746.         expand_goto (ffeste_io_end_);
  3747.         expand_end_cond ();
  3748.       }
  3749.  
  3750.     /* if (iostat>0) goto err_label; */
  3751.  
  3752.     if ((ffeste_io_err_ != NULL_TREE)
  3753.         && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
  3754.       {
  3755.         expand_start_cond (ffecom_truth_value
  3756.                    (ffecom_2 (GT_EXPR, integer_type_node,
  3757.                       iostat,
  3758.                       ffecom_integer_zero_node)),
  3759.                    0);
  3760.         expand_goto (ffeste_io_err_);
  3761.         expand_end_cond ();
  3762.       }
  3763.  
  3764.       }
  3765.  
  3766.     /* If we've got a temp iostat, pop the temp. */
  3767.  
  3768.     if (ffeste_io_iostat_is_temp_)
  3769.       ffecom_pop_tempvar (ffeste_io_iostat_);
  3770.  
  3771.     ffecom_pop_calltemps ();
  3772.  
  3773.     clear_momentary ();
  3774.   }
  3775. #endif
  3776. #endif
  3777. }
  3778.  
  3779. /* ffeste_R910_start -- WRITE(...) statement list begin
  3780.  
  3781.    ffeste_R910_start();
  3782.  
  3783.    Verify that WRITE is valid here, and begin accepting items in the
  3784.    list.  */
  3785.  
  3786. void
  3787. ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
  3788.            ffestvFormat format, bool rec)
  3789. {
  3790.   ffeste_check_start_ ();
  3791.  
  3792. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3793.   switch (format)
  3794.     {
  3795.     case FFESTV_formatNONE:
  3796.       if (rec)
  3797.     fputs ("+ WRITE_ufdac (", stdout);
  3798.       else
  3799.     fputs ("+ WRITE_ufseq_or_idx (", stdout);
  3800.       break;
  3801.  
  3802.     case FFESTV_formatLABEL:
  3803.     case FFESTV_formatCHAREXPR:
  3804.     case FFESTV_formatINTEXPR:
  3805.       if (rec)
  3806.     fputs ("+ WRITE_fmdac (", stdout);
  3807.       else if (unit == FFESTV_unitCHAREXPR)
  3808.     fputs ("+ WRITE_fmint (", stdout);
  3809.       else
  3810.     fputs ("+ WRITE_fmseq_or_idx (", stdout);
  3811.       break;
  3812.  
  3813.     case FFESTV_formatASTERISK:
  3814.       if (unit == FFESTV_unitCHAREXPR)
  3815.     fputs ("+ WRITE_lsint (", stdout);
  3816.       else
  3817.     fputs ("+ WRITE_lsseq (", stdout);
  3818.       break;
  3819.  
  3820.     case FFESTV_formatNAMELIST:
  3821.       fputs ("+ WRITE_nlseq (", stdout);
  3822.       break;
  3823.  
  3824.     default:
  3825.       assert ("Unexpected kind of format item in R910 WRITE" == NULL);
  3826.     }
  3827.  
  3828.   ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
  3829.   ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
  3830.   ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
  3831.   ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
  3832.   ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
  3833.   ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
  3834.   ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
  3835.   fputs (") ", stdout);
  3836. #else
  3837. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3838.  
  3839. #define specified(something) (info->write_spec[something].kw_or_val_present)
  3840.  
  3841.   ffeste_emit_line_note_ ();
  3842.  
  3843.   /* Do the real work. */
  3844.  
  3845.   {
  3846.     ffecomGfrt start;
  3847.     ffecomGfrt end;
  3848.     tree cilist;
  3849.     bool iostat;
  3850.     bool errl;
  3851.  
  3852.     /* First determine the start, per-item, and end run-time functions to
  3853.        call.  The per-item function is picked by choosing an ffeste functio
  3854.        to call to handle a given item; it knows how to generate a call to the
  3855.        appropriate run-time function, and is called an "io driver".  It
  3856.        handles the implied-DO construct, for example. */
  3857.  
  3858.     switch (format)
  3859.       {
  3860.       case FFESTV_formatNONE:    /* no FMT= */
  3861.     ffeste_io_driver_ = ffeste_io_douio_;
  3862.     if (rec)
  3863.       start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
  3864.     else
  3865.       start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
  3866.     break;
  3867.  
  3868.       case FFESTV_formatLABEL:    /* FMT=10 */
  3869.       case FFESTV_formatCHAREXPR:    /* FMT='(I10)' */
  3870.       case FFESTV_formatINTEXPR:    /* FMT=I [after ASSIGN 10 TO I] */
  3871.     ffeste_io_driver_ = ffeste_io_dofio_;
  3872.     if (rec)
  3873.       start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
  3874.     else if (unit == FFESTV_unitCHAREXPR)
  3875.       start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
  3876.     else
  3877.       start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
  3878.     break;
  3879.  
  3880.       case FFESTV_formatASTERISK:    /* FMT=* */
  3881.     ffeste_io_driver_ = ffeste_io_dolio_;
  3882.     if (unit == FFESTV_unitCHAREXPR)
  3883.       start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
  3884.     else
  3885.       start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
  3886.     break;
  3887.  
  3888.       case FFESTV_formatNAMELIST:    /* FMT=FOO or NML=FOO [NAMELIST
  3889.                        /FOO/] */
  3890.     ffeste_io_driver_ = NULL;    /* No start or driver function. */
  3891.     start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
  3892.     break;
  3893.  
  3894.       default:
  3895.     assert ("Weird stuff" == NULL);
  3896.     start = FFECOM_gfrt, end = FFECOM_gfrt;
  3897.     break;
  3898.       }
  3899.     ffeste_io_endgfrt_ = end;
  3900.  
  3901.     iostat = specified (FFESTP_writeixIOSTAT);
  3902.     errl = specified (FFESTP_writeixERR);
  3903.  
  3904.     ffecom_push_calltemps ();
  3905.  
  3906.     if (unit == FFESTV_unitCHAREXPR)
  3907.       {
  3908.     cilist = ffeste_io_icilist_ (errl || iostat,
  3909.                 info->write_spec[FFESTP_writeixUNIT].u.expr,
  3910.                      FALSE, format,
  3911.                    &info->write_spec[FFESTP_writeixFORMAT]);
  3912.       }
  3913.     else
  3914.       {
  3915.     cilist = ffeste_io_cilist_ (errl || iostat, unit,
  3916.                 info->write_spec[FFESTP_writeixUNIT].u.expr,
  3917.                     6, FALSE, format,
  3918.                     &info->write_spec[FFESTP_writeixFORMAT],
  3919.                     rec,
  3920.                 info->write_spec[FFESTP_writeixREC].u.expr);
  3921.       }
  3922.  
  3923.     ffeste_io_end_ = NULL_TREE;
  3924.  
  3925.     if (errl)
  3926.       {                /* ERR= */
  3927.     ffeste_io_err_
  3928.       = ffeste_io_abort_
  3929.       = ffecom_lookup_label
  3930.       (info->write_spec[FFESTP_writeixERR].u.label);
  3931.     ffeste_io_abort_is_temp_ = FALSE;
  3932.       }
  3933.     else
  3934.       {                /* no ERR= */
  3935.     ffeste_io_err_ = NULL_TREE;
  3936.  
  3937.     if ((ffeste_io_abort_is_temp_ = iostat))
  3938.       ffeste_io_abort_ = ffecom_temp_label ();
  3939.     else
  3940.       ffeste_io_abort_ = NULL_TREE;
  3941.       }
  3942.  
  3943.     if (iostat)
  3944.       {                /* IOSTAT= */
  3945.     ffeste_io_iostat_is_temp_ = FALSE;
  3946.     ffeste_io_iostat_ = ffecom_expr
  3947.       (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
  3948.       }
  3949.     else if (ffeste_io_abort_ != NULL_TREE)
  3950.       {                /* no IOSTAT= but ERR= */
  3951.     ffeste_io_iostat_is_temp_ = TRUE;
  3952.     ffeste_io_iostat_
  3953.       = ffecom_push_tempvar (ffecom_integer_type_node,
  3954.                  FFETARGET_charactersizeNONE, -1, FALSE);
  3955.       }
  3956.     else
  3957.       {                /* no IOSTAT=, or ERR= */
  3958.     ffeste_io_iostat_is_temp_ = FALSE;
  3959.     ffeste_io_iostat_ = NULL_TREE;
  3960.       }
  3961.  
  3962.     /* If there is no end function, then there are no item functions (i.e.
  3963.        it's a NAMELIST), and vice versa by the way.  In this situation, don't
  3964.        generate the "if (iostat != 0) goto label;" if the label is temp abort
  3965.        label, since we're gonna fall through to there anyway.  */
  3966.  
  3967.     ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
  3968.              (ffeste_io_abort_ != NULL_TREE)
  3969.              && (!ffeste_io_abort_is_temp_
  3970.              || (end != FFECOM_gfrt)));
  3971.   }
  3972.  
  3973. #undef specified
  3974.  
  3975.   push_momentary ();
  3976. #endif
  3977. #endif
  3978. }
  3979.  
  3980. /* ffeste_R910_item -- WRITE statement i/o item
  3981.  
  3982.    ffeste_R910_item(expr,expr_token);
  3983.  
  3984.    Implement output-list expression.  */
  3985.  
  3986. void
  3987. ffeste_R910_item (ffebld expr, ffelexToken expr_token)
  3988. {
  3989.   ffeste_check_item_ ();
  3990.  
  3991. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  3992.   ffebld_dump (expr);
  3993.   fputc (',', stdout);
  3994. #else
  3995. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  3996.   if (expr == NULL)
  3997.     return;
  3998.   if (ffebld_op (expr) == FFEBLD_opANY)
  3999.     return;
  4000.   if (ffebld_op (expr) == FFEBLD_opIMPDO)
  4001.     ffeste_io_impdo_ (expr, expr_token);
  4002.   else
  4003.     ffeste_io_call_ ((*ffeste_io_driver_) (expr),
  4004.              (ffeste_io_abort_ != NULL_TREE));
  4005.   clear_momentary ();
  4006. #endif
  4007. #endif
  4008. }
  4009.  
  4010. /* ffeste_R910_finish -- WRITE statement list complete
  4011.  
  4012.    ffeste_R910_finish();
  4013.  
  4014.    Just wrap up any local activities.  */
  4015.  
  4016. void
  4017. ffeste_R910_finish ()
  4018. {
  4019.   ffeste_check_finish_ ();
  4020.  
  4021. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4022.   fputc ('\n', stdout);
  4023. #else
  4024. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4025.  
  4026.   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  4027.      label, since we're gonna fall through to there anyway. */
  4028.  
  4029.   /* SPECIAL CASE: for e_rsle and e_rsli, don't generate the check AND don't
  4030.      even let ffeste_io_call_ bother writing to IOSTAT=, since
  4031.      dmg@research.att.com claims that e_[rw]sl[ei] always return 0. */
  4032.  
  4033.   {
  4034.     if (ffeste_io_driver_ == ffeste_io_dolio_)
  4035.       ffeste_io_iostat_ = NULL_TREE;
  4036.  
  4037.     if (ffeste_io_endgfrt_ != FFECOM_gfrt)
  4038.       ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
  4039.                !ffeste_io_abort_is_temp_
  4040.                && (ffeste_io_abort_ != NULL_TREE)
  4041.                && (ffeste_io_driver_ != ffeste_io_dolio_));
  4042.  
  4043.     clear_momentary ();
  4044.     pop_momentary ();
  4045.  
  4046.     /* If we've got a temp label, generate its code here. */
  4047.  
  4048.     if (ffeste_io_abort_is_temp_)
  4049.       {
  4050.     DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  4051.     emit_nop ();
  4052.     expand_label (ffeste_io_abort_);
  4053.  
  4054.     assert (ffeste_io_err_ == NULL_TREE);
  4055.       }
  4056.  
  4057.     /* If we've got a temp iostat, pop the temp. */
  4058.  
  4059.     if (ffeste_io_iostat_is_temp_)
  4060.       ffecom_pop_tempvar (ffeste_io_iostat_);
  4061.  
  4062.     ffecom_pop_calltemps ();
  4063.  
  4064.     clear_momentary ();
  4065.   }
  4066. #endif
  4067. #endif
  4068. }
  4069.  
  4070. /* ffeste_R911_start -- PRINT statement list begin
  4071.  
  4072.    ffeste_R911_start();
  4073.  
  4074.    Verify that PRINT is valid here, and begin accepting items in the
  4075.    list.  */
  4076.  
  4077. void
  4078. ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
  4079. {
  4080.   ffeste_check_start_ ();
  4081.  
  4082. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4083.   switch (format)
  4084.     {
  4085.     case FFESTV_formatLABEL:
  4086.     case FFESTV_formatCHAREXPR:
  4087.     case FFESTV_formatINTEXPR:
  4088.       fputs ("+ PRINT_fm ", stdout);
  4089.       break;
  4090.  
  4091.     case FFESTV_formatASTERISK:
  4092.       fputs ("+ PRINT_ls ", stdout);
  4093.       break;
  4094.  
  4095.     case FFESTV_formatNAMELIST:
  4096.       fputs ("+ PRINT_nl ", stdout);
  4097.       break;
  4098.  
  4099.     default:
  4100.       assert ("Unexpected kind of format item in R911 PRINT" == NULL);
  4101.     }
  4102.   ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
  4103.   fputc (' ', stdout);
  4104. #else
  4105. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4106.  
  4107.   ffeste_emit_line_note_ ();
  4108.  
  4109.   /* Do the real work. */
  4110.  
  4111.   {
  4112.     ffecomGfrt start;
  4113.     ffecomGfrt end;
  4114.     tree cilist;
  4115.  
  4116.     /* First determine the start, per-item, and end run-time functions to
  4117.        call.  The per-item function is picked by choosing an ffeste functio
  4118.        to call to handle a given item; it knows how to generate a call to the
  4119.        appropriate run-time function, and is called an "io driver".  It
  4120.        handles the implied-DO construct, for example. */
  4121.  
  4122.     switch (format)
  4123.       {
  4124.       case FFESTV_formatLABEL:    /* FMT=10 */
  4125.       case FFESTV_formatCHAREXPR:    /* FMT='(I10)' */
  4126.       case FFESTV_formatINTEXPR:    /* FMT=I [after ASSIGN 10 TO I] */
  4127.     ffeste_io_driver_ = ffeste_io_dofio_;
  4128.     start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
  4129.     break;
  4130.  
  4131.       case FFESTV_formatASTERISK:    /* FMT=* */
  4132.     ffeste_io_driver_ = ffeste_io_dolio_;
  4133.     start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
  4134.     break;
  4135.  
  4136.       case FFESTV_formatNAMELIST:    /* FMT=FOO or NML=FOO [NAMELIST
  4137.                        /FOO/] */
  4138.     ffeste_io_driver_ = NULL;    /* No start or driver function. */
  4139.     start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
  4140.     break;
  4141.  
  4142.       default:
  4143.     assert ("Weird stuff" == NULL);
  4144.     start = FFECOM_gfrt, end = FFECOM_gfrt;
  4145.     break;
  4146.       }
  4147.     ffeste_io_endgfrt_ = end;
  4148.  
  4149.     ffecom_push_calltemps ();
  4150.  
  4151.     cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
  4152.               &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
  4153.  
  4154.     ffeste_io_end_ = NULL_TREE;
  4155.     ffeste_io_err_ = NULL_TREE;
  4156.     ffeste_io_abort_ = NULL_TREE;
  4157.     ffeste_io_abort_is_temp_ = FALSE;
  4158.     ffeste_io_iostat_is_temp_ = FALSE;
  4159.     ffeste_io_iostat_ = NULL_TREE;
  4160.  
  4161.     /* If there is no end function, then there are no item functions (i.e.
  4162.        it's a NAMELIST), and vice versa by the way.  In this situation, don't
  4163.        generate the "if (iostat != 0) goto label;" if the label is temp abort
  4164.        label, since we're gonna fall through to there anyway.  */
  4165.  
  4166.     ffeste_io_call_ (ffecom_call_gfrt (start, cilist),
  4167.              (ffeste_io_abort_ != NULL_TREE)
  4168.              && (!ffeste_io_abort_is_temp_
  4169.              || (end != FFECOM_gfrt)));
  4170.   }
  4171.  
  4172.   push_momentary ();
  4173. #endif
  4174. #endif
  4175. }
  4176.  
  4177. /* ffeste_R911_item -- PRINT statement i/o item
  4178.  
  4179.    ffeste_R911_item(expr,expr_token);
  4180.  
  4181.    Implement output-list expression.  */
  4182.  
  4183. void
  4184. ffeste_R911_item (ffebld expr, ffelexToken expr_token)
  4185. {
  4186.   ffeste_check_item_ ();
  4187.  
  4188. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4189.   ffebld_dump (expr);
  4190.   fputc (',', stdout);
  4191. #else
  4192. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4193.   if (expr == NULL)
  4194.     return;
  4195.   if (ffebld_op (expr) == FFEBLD_opANY)
  4196.     return;
  4197.   if (ffebld_op (expr) == FFEBLD_opIMPDO)
  4198.     ffeste_io_impdo_ (expr, expr_token);
  4199.   else
  4200.     ffeste_io_call_ ((*ffeste_io_driver_) (expr), FALSE);
  4201.   clear_momentary ();
  4202. #endif
  4203. #endif
  4204. }
  4205.  
  4206. /* ffeste_R911_finish -- PRINT statement list complete
  4207.  
  4208.    ffeste_R911_finish();
  4209.  
  4210.    Just wrap up any local activities.  */
  4211.  
  4212. void
  4213. ffeste_R911_finish ()
  4214. {
  4215.   ffeste_check_finish_ ();
  4216.  
  4217. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4218.   fputc ('\n', stdout);
  4219. #else
  4220. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4221.   {
  4222.     if (ffeste_io_endgfrt_ != FFECOM_gfrt)
  4223.       ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
  4224.                FALSE);
  4225.  
  4226.     ffecom_pop_calltemps ();
  4227.  
  4228.     clear_momentary ();
  4229.     pop_momentary ();
  4230.     clear_momentary ();
  4231.   }
  4232. #endif
  4233. #endif
  4234. }
  4235.  
  4236. /* ffeste_R919 -- BACKSPACE statement
  4237.  
  4238.    ffeste_R919();
  4239.  
  4240.    Make sure a BACKSPACE is valid in the current context, and implement it.  */
  4241.  
  4242. void
  4243. ffeste_R919 (ffestpBeruStmt *info)
  4244. {
  4245.   ffeste_check_simple_ ();
  4246.  
  4247. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4248.   fputs ("+ BACKSPACE (", stdout);
  4249.   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
  4250.   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
  4251.   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
  4252.   fputs (")\n", stdout);
  4253. #else
  4254. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4255.   ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
  4256. #endif
  4257. #endif
  4258. }
  4259.  
  4260. /* ffeste_R920 -- ENDFILE statement
  4261.  
  4262.    ffeste_R920();
  4263.  
  4264.    Make sure a ENDFILE is valid in the current context, and implement it.  */
  4265.  
  4266. void
  4267. ffeste_R920 (ffestpBeruStmt *info)
  4268. {
  4269.   ffeste_check_simple_ ();
  4270.  
  4271. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4272.   fputs ("+ ENDFILE (", stdout);
  4273.   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
  4274.   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
  4275.   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
  4276.   fputs (")\n", stdout);
  4277. #else
  4278. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4279.   ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
  4280. #endif
  4281. #endif
  4282. }
  4283.  
  4284. /* ffeste_R921 -- REWIND statement
  4285.  
  4286.    ffeste_R921();
  4287.  
  4288.    Make sure a REWIND is valid in the current context, and implement it.  */
  4289.  
  4290. void
  4291. ffeste_R921 (ffestpBeruStmt *info)
  4292. {
  4293.   ffeste_check_simple_ ();
  4294.  
  4295. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4296.   fputs ("+ REWIND (", stdout);
  4297.   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
  4298.   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
  4299.   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
  4300.   fputs (")\n", stdout);
  4301. #else
  4302. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4303.   ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
  4304. #endif
  4305. #endif
  4306. }
  4307.  
  4308. /* ffeste_R923A -- INQUIRE statement (non-IOLENGTH version)
  4309.  
  4310.    ffeste_R923A(bool by_file);
  4311.  
  4312.    Make sure an INQUIRE is valid in the current context, and implement it.  */
  4313.  
  4314. void
  4315. ffeste_R923A (ffestpInquireStmt *info, bool by_file)
  4316. {
  4317.   ffeste_check_simple_ ();
  4318.  
  4319. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4320.   if (by_file)
  4321.     {
  4322.       fputs ("+ INQUIRE_file (", stdout);
  4323.       ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
  4324.     }
  4325.   else
  4326.     {
  4327.       fputs ("+ INQUIRE_unit (", stdout);
  4328.       ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
  4329.     }
  4330.   ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
  4331.   ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
  4332.   ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
  4333.   ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
  4334.   ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
  4335.   ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
  4336.   ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
  4337.   ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
  4338.   ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
  4339.   ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
  4340.   ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
  4341.   ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
  4342.   ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
  4343.   ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
  4344.   ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
  4345.   ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
  4346.   ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
  4347.   ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
  4348.   ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
  4349.   ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
  4350.   ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
  4351.   ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
  4352.   ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
  4353.   ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
  4354.   ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
  4355.   ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
  4356.   ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
  4357.   ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
  4358.   fputs (")\n", stdout);
  4359. #else
  4360. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4361.   {
  4362.     tree args;
  4363.     bool iostat;
  4364.     bool errl;
  4365.  
  4366. #define specified(something) (info->inquire_spec[something].kw_or_val_present)
  4367.  
  4368.     ffeste_emit_line_note_ ();
  4369.  
  4370.     iostat = specified (FFESTP_inquireixIOSTAT);
  4371.     errl = specified (FFESTP_inquireixERR);
  4372.  
  4373.     ffecom_push_calltemps ();
  4374.  
  4375.     args = ffeste_io_inlist_ (errl || iostat,
  4376.                   &info->inquire_spec[FFESTP_inquireixUNIT],
  4377.                   &info->inquire_spec[FFESTP_inquireixFILE],
  4378.                   &info->inquire_spec[FFESTP_inquireixEXIST],
  4379.                   &info->inquire_spec[FFESTP_inquireixOPENED],
  4380.                   &info->inquire_spec[FFESTP_inquireixNUMBER],
  4381.                   &info->inquire_spec[FFESTP_inquireixNAMED],
  4382.                   &info->inquire_spec[FFESTP_inquireixNAME],
  4383.                   &info->inquire_spec[FFESTP_inquireixACCESS],
  4384.                 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
  4385.                   &info->inquire_spec[FFESTP_inquireixDIRECT],
  4386.                   &info->inquire_spec[FFESTP_inquireixFORM],
  4387.                   &info->inquire_spec[FFESTP_inquireixFORMATTED],
  4388.                &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
  4389.                   &info->inquire_spec[FFESTP_inquireixRECL],
  4390.                   &info->inquire_spec[FFESTP_inquireixNEXTREC],
  4391.                   &info->inquire_spec[FFESTP_inquireixBLANK]);
  4392.  
  4393.     if (errl)
  4394.       {
  4395.     ffeste_io_err_
  4396.       = ffeste_io_abort_
  4397.       = ffecom_lookup_label
  4398.       (info->inquire_spec[FFESTP_inquireixERR].u.label);
  4399.     ffeste_io_abort_is_temp_ = FALSE;
  4400.       }
  4401.     else
  4402.       {
  4403.     ffeste_io_err_ = NULL_TREE;
  4404.  
  4405.     if ((ffeste_io_abort_is_temp_ = iostat))
  4406.       ffeste_io_abort_ = ffecom_temp_label ();
  4407.     else
  4408.       ffeste_io_abort_ = NULL_TREE;
  4409.       }
  4410.  
  4411.     if (iostat)
  4412.       {                /* IOSTAT= */
  4413.     ffeste_io_iostat_is_temp_ = FALSE;
  4414.     ffeste_io_iostat_ = ffecom_expr
  4415.       (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
  4416.       }
  4417.     else if (ffeste_io_abort_ != NULL_TREE)
  4418.       {                /* no IOSTAT= but ERR= */
  4419.     ffeste_io_iostat_is_temp_ = TRUE;
  4420.     ffeste_io_iostat_
  4421.       = ffecom_push_tempvar (ffecom_integer_type_node,
  4422.                  FFETARGET_charactersizeNONE, -1, FALSE);
  4423.       }
  4424.     else
  4425.       {                /* no IOSTAT=, or ERR= */
  4426.     ffeste_io_iostat_is_temp_ = FALSE;
  4427.     ffeste_io_iostat_ = NULL_TREE;
  4428.       }
  4429.  
  4430.     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
  4431.        label, since we're gonna fall through to there anyway. */
  4432.  
  4433.     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args),
  4434.           !ffeste_io_abort_is_temp_ && (ffeste_io_abort_ != NULL_TREE));
  4435.  
  4436.     /* If we've got a temp label, generate its code here. */
  4437.  
  4438.     if (ffeste_io_abort_is_temp_)
  4439.       {
  4440.     DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
  4441.     emit_nop ();
  4442.     expand_label (ffeste_io_abort_);
  4443.  
  4444.     assert (ffeste_io_err_ == NULL_TREE);
  4445.       }
  4446.  
  4447.     /* If we've got a temp iostat, pop the temp. */
  4448.  
  4449.     if (ffeste_io_iostat_is_temp_)
  4450.       ffecom_pop_tempvar (ffeste_io_iostat_);
  4451.  
  4452.     ffecom_pop_calltemps ();
  4453.  
  4454. #undef specified
  4455.   }
  4456.  
  4457.   clear_momentary ();
  4458. #endif
  4459. #endif
  4460. }
  4461.  
  4462. /* ffeste_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
  4463.  
  4464.    ffeste_R923B_start();
  4465.  
  4466.    Verify that INQUIRE is valid here, and begin accepting items in the
  4467.    list.  */
  4468.  
  4469. void
  4470. ffeste_R923B_start (ffestpInquireStmt *info)
  4471. {
  4472.   ffeste_check_start_ ();
  4473.  
  4474. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4475.   fputs ("+ INQUIRE (", stdout);
  4476.   ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
  4477.   fputs (") ", stdout);
  4478. #else
  4479. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4480.   assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
  4481.   ffeste_emit_line_note_ ();
  4482.   clear_momentary ();
  4483. #endif
  4484. #endif
  4485. }
  4486.  
  4487. /* ffeste_R923B_item -- INQUIRE statement i/o item
  4488.  
  4489.    ffeste_R923B_item(expr,expr_token);
  4490.  
  4491.    Implement output-list expression.  */
  4492.  
  4493. void
  4494. ffeste_R923B_item (ffebld expr)
  4495. {
  4496.   ffeste_check_item_ ();
  4497.  
  4498. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4499.   ffebld_dump (expr);
  4500.   fputc (',', stdout);
  4501. #else
  4502. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4503.   clear_momentary ();
  4504. #endif
  4505. #endif
  4506. }
  4507.  
  4508. /* ffeste_R923B_finish -- INQUIRE statement list complete
  4509.  
  4510.    ffeste_R923B_finish();
  4511.  
  4512.    Just wrap up any local activities.  */
  4513.  
  4514. void
  4515. ffeste_R923B_finish ()
  4516. {
  4517.   ffeste_check_finish_ ();
  4518.  
  4519. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4520.   fputc ('\n', stdout);
  4521. #else
  4522. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4523.   clear_momentary ();
  4524. #endif
  4525. #endif
  4526. }
  4527.  
  4528. /* ffeste_R1001 -- FORMAT statement
  4529.  
  4530.    ffeste_R1001(format_list);  */
  4531.  
  4532. void
  4533. ffeste_R1001 (ffests s)
  4534. {
  4535.   ffeste_check_simple_ ();
  4536.  
  4537. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4538.   fprintf (stdout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
  4539. #else
  4540. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4541.   {
  4542.     tree t;
  4543.     tree ttype;
  4544.     tree maxindex;
  4545.     tree var;
  4546.  
  4547.     assert (ffeste_label_formatdef_ != NULL);
  4548.  
  4549.     ffeste_emit_line_note_ ();
  4550.  
  4551.     t = build_string (ffests_length (s), ffests_text (s));
  4552.  
  4553.     TREE_TYPE (t)
  4554.       = build_type_variant (build_array_type
  4555.                 (char_type_node,
  4556.                  build_range_type (integer_type_node,
  4557.                            integer_one_node,
  4558.                          build_int_2 (ffests_length (s),
  4559.                               0))),
  4560.                 1, 0);
  4561.     TREE_CONSTANT (t) = 1;
  4562.     TREE_STATIC (t) = 1;
  4563.  
  4564.     push_obstacks_nochange ();
  4565.     end_temporary_allocation ();
  4566.  
  4567.     var = ffecom_lookup_label (ffeste_label_formatdef_);
  4568.     if ((var != NULL_TREE)
  4569.     && (TREE_CODE (var) != ERROR_MARK))
  4570.       {
  4571.     DECL_INITIAL (var) = t;
  4572.     maxindex = build_int_2 (ffests_length (s) - 1, 0);
  4573.     ttype = TREE_TYPE (var);
  4574.     TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
  4575.                         integer_zero_node,
  4576.                         maxindex);
  4577.     if (!TREE_TYPE (maxindex))
  4578.       TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
  4579.     layout_type (ttype);
  4580.     rest_of_decl_compilation (var, NULL, 1, 0);
  4581.     expand_decl (var);
  4582.     expand_decl_init (var);
  4583.       }
  4584.  
  4585.     resume_temporary_allocation ();
  4586.     pop_obstacks ();
  4587.  
  4588.     ffeste_label_formatdef_ = NULL;
  4589.   }
  4590. #endif
  4591. #endif
  4592. }
  4593.  
  4594. /* ffeste_R1103 -- End a PROGRAM
  4595.  
  4596.    ffeste_R1103();  */
  4597.  
  4598. void
  4599. ffeste_R1103 ()
  4600. {
  4601. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4602.   fputs ("+ END_PROGRAM\n", stdout);
  4603. #else
  4604. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4605. #endif
  4606. #endif
  4607. }
  4608.  
  4609. /* ffeste_R1112 -- End a BLOCK DATA
  4610.  
  4611.    ffeste_R1112(TRUE);    */
  4612.  
  4613. void
  4614. ffeste_R1112 ()
  4615. {
  4616. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4617.   fputs ("* END_BLOCK_DATA\n", stdout);
  4618. #else
  4619. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4620. #endif
  4621. #endif
  4622. }
  4623.  
  4624. /* ffeste_R1212 -- CALL statement
  4625.  
  4626.    ffeste_R1212(expr,expr_token);
  4627.  
  4628.    Make sure statement is valid here; implement.  */
  4629.  
  4630. void
  4631. ffeste_R1212 (ffebld expr)
  4632. {
  4633.   ffeste_check_simple_ ();
  4634.  
  4635. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4636.   fputs ("+ CALL ", stdout);
  4637.   ffebld_dump (expr);
  4638.   fputc ('\n', stdout);
  4639. #else
  4640. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4641.   {
  4642.     ffebld args = ffebld_right (expr);
  4643.     ffebld arg;
  4644.     ffebld labels = NULL;    /* First in list of LABTERs. */
  4645.     ffebld prevlabels = NULL;
  4646.     ffebld prevargs = NULL;
  4647.  
  4648.     ffeste_emit_line_note_ ();
  4649.  
  4650.     /* Here we split the list at ffebld_right(expr) into two lists: one at
  4651.        ffebld_right(expr) consisting of all items that are not LABTERs, the
  4652.        other at labels consisting of all items that are LABTERs.  Then, if
  4653.        the latter list is NULL, we have an ordinary call, else we have a call
  4654.        with alternate returns. */
  4655.  
  4656.     for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
  4657.       {
  4658.     if (((arg = ffebld_head (args)) == NULL)
  4659.         || (ffebld_op (arg) != FFEBLD_opLABTER))
  4660.       {
  4661.         if (prevargs == NULL)
  4662.           {
  4663.         prevargs = args;
  4664.         ffebld_set_right (expr, args);
  4665.           }
  4666.         else
  4667.           {
  4668.         ffebld_set_trail (prevargs, args);
  4669.         prevargs = args;
  4670.           }
  4671.       }
  4672.     else
  4673.       {
  4674.         if (prevlabels == NULL)
  4675.           {
  4676.         prevlabels = labels = args;
  4677.           }
  4678.         else
  4679.           {
  4680.         ffebld_set_trail (prevlabels, args);
  4681.         prevlabels = args;
  4682.           }
  4683.       }
  4684.       }
  4685.     if (prevlabels == NULL)
  4686.       labels = NULL;
  4687.     else
  4688.       ffebld_set_trail (prevlabels, NULL);
  4689.     if (prevargs == NULL)
  4690.       ffebld_set_right (expr, NULL);
  4691.     else
  4692.       ffebld_set_trail (prevargs, NULL);
  4693.  
  4694.     if (labels == NULL)
  4695.       expand_expr_stmt (ffecom_expr (expr));
  4696.     else
  4697.       {
  4698.     tree texpr;
  4699.     tree value;
  4700.     tree tlabel;
  4701.     int caseno;
  4702.     int pushok;
  4703.     tree duplicate;
  4704.  
  4705.     texpr = ffecom_expr (expr);
  4706.     expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
  4707.     push_momentary ();    /* In case of many labels, keep 'em cleared
  4708.                    out. */
  4709.     for (caseno = 1;
  4710.          labels != NULL;
  4711.          ++caseno, labels = ffebld_trail (labels))
  4712.       {
  4713.         value = build_int_2 (caseno, 0);
  4714.         tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
  4715.  
  4716.         pushok = pushcase (value, convert, tlabel, &duplicate);
  4717.         assert (pushok == 0);
  4718.         tlabel
  4719.           = ffecom_lookup_label (ffebld_labter (ffebld_head (labels)));
  4720.         if ((tlabel == NULL_TREE)
  4721.         || (TREE_CODE (tlabel) == ERROR_MARK))
  4722.           continue;
  4723.         TREE_USED (tlabel) = 1;
  4724.         expand_goto (tlabel);
  4725.         clear_momentary ();
  4726.       }
  4727.  
  4728.     pop_momentary ();
  4729.     expand_end_case (texpr);
  4730.       }
  4731.     clear_momentary ();
  4732.   }
  4733. #endif
  4734. #endif
  4735. }
  4736.  
  4737. /* ffeste_R1221 -- End a FUNCTION
  4738.  
  4739.    ffeste_R1221(TRUE);    */
  4740.  
  4741. void
  4742. ffeste_R1221 ()
  4743. {
  4744. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4745.   fputs ("+ END_FUNCTION\n", stdout);
  4746. #else
  4747. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4748. #endif
  4749. #endif
  4750. }
  4751.  
  4752. /* ffeste_R1225 -- End a SUBROUTINE
  4753.  
  4754.    ffeste_R1225(TRUE);    */
  4755.  
  4756. void
  4757. ffeste_R1225 ()
  4758. {
  4759. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4760.   fprintf (stdout, "+ END_SUBROUTINE\n");
  4761. #else
  4762. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4763. #endif
  4764. #endif
  4765. }
  4766.  
  4767. /* ffeste_R1226 -- ENTRY statement
  4768.  
  4769.    ffeste_R1226(entryname,arglist,ending_token);
  4770.  
  4771.    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
  4772.    entry point name, and so on.     */
  4773.  
  4774. void
  4775. ffeste_R1226 (ffesymbol entry)
  4776. {
  4777.   ffeste_check_simple_ ();
  4778.  
  4779. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4780.   fprintf (stdout, "+ ENTRY %s", ffesymbol_text (entry));
  4781.   if (ffesymbol_dummyargs (entry) != NULL)
  4782.     {
  4783.       ffebld argh;
  4784.  
  4785.       fputc ('(', stdout);
  4786.       for (argh = ffesymbol_dummyargs (entry);
  4787.        argh != NULL;
  4788.        argh = ffebld_trail (argh))
  4789.     {
  4790.       assert (ffebld_head (argh) != NULL);
  4791.       switch (ffebld_op (ffebld_head (argh)))
  4792.         {
  4793.         case FFEBLD_opSYMTER:
  4794.           fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
  4795.              stdout);
  4796.           break;
  4797.  
  4798.         case FFEBLD_opSTAR:
  4799.           fputc ('*', stdout);
  4800.           break;
  4801.  
  4802.         default:
  4803.           fputc ('?', stdout);
  4804.           ffebld_dump (ffebld_head (argh));
  4805.           fputc ('?', stdout);
  4806.           break;
  4807.         }
  4808.       if (ffebld_trail (argh) != NULL)
  4809.         fputc (',', stdout);
  4810.     }
  4811.       fputc (')', stdout);
  4812.     }
  4813.   fputc ('\n', stdout);
  4814. #else
  4815. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4816.   {
  4817.     tree label = ffesymbol_hook (entry).length_tree;
  4818.  
  4819.     ffeste_emit_line_note_ ();
  4820.  
  4821.     DECL_INITIAL (label) = error_mark_node;
  4822.     emit_nop ();
  4823.     expand_label (label);
  4824.  
  4825.     clear_momentary ();
  4826.   }
  4827. #endif
  4828. #endif
  4829. }
  4830.  
  4831. /* ffeste_R1227 -- RETURN statement
  4832.  
  4833.    ffeste_R1227(expr);
  4834.  
  4835.    Make sure statement is valid here; implement.  expr and expr_token are
  4836.    both NULL if there was no expression.  */
  4837.  
  4838. void
  4839. ffeste_R1227 (ffestw block, ffebld expr)
  4840. {
  4841.   ffeste_check_simple_ ();
  4842.  
  4843. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4844.   if (expr == NULL)
  4845.     {
  4846.       fputs ("+ RETURN\n", stdout);
  4847.     }
  4848.   else
  4849.     {
  4850.       fputs ("+ RETURN_alternate ", stdout);
  4851.       ffebld_dump (expr);
  4852.       fputc ('\n', stdout);
  4853.     }
  4854. #else
  4855. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4856.   {
  4857.     tree rtn;
  4858.  
  4859.     ffeste_emit_line_note_ ();
  4860.     ffecom_push_calltemps ();
  4861.  
  4862.     rtn = ffecom_return_expr (expr);
  4863.  
  4864.     if (rtn == NULL_TREE)
  4865.       expand_null_return ();
  4866.     else
  4867.       {
  4868.     tree result = DECL_RESULT (current_function_decl);
  4869.  
  4870.     expand_return (ffecom_modify (NULL_TREE,
  4871.                       result,
  4872.                       convert (TREE_TYPE (result),
  4873.                            rtn)));
  4874.       }
  4875.  
  4876.     ffecom_pop_calltemps ();
  4877.     clear_momentary ();
  4878.   }
  4879. #endif
  4880. #endif
  4881. }
  4882.  
  4883. /* ffeste_V018_start -- REWRITE(...) statement list begin
  4884.  
  4885.    ffeste_V018_start();
  4886.  
  4887.    Verify that REWRITE is valid here, and begin accepting items in the
  4888.    list.  */
  4889.  
  4890. #if FFESTR_VXT
  4891. void
  4892. ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
  4893. {
  4894.   ffeste_check_start_ ();
  4895.  
  4896. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4897.   switch (format)
  4898.     {
  4899.     case FFESTV_formatNONE:
  4900.       fputs ("+ REWRITE_uf (", stdout);
  4901.       break;
  4902.  
  4903.     case FFESTV_formatLABEL:
  4904.     case FFESTV_formatCHAREXPR:
  4905.     case FFESTV_formatINTEXPR:
  4906.       fputs ("+ REWRITE_fm (", stdout);
  4907.       break;
  4908.  
  4909.     default:
  4910.       assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
  4911.     }
  4912.   ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
  4913.   ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
  4914.   ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
  4915.   ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
  4916.   fputs (") ", stdout);
  4917. #else
  4918. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4919. #endif
  4920. #endif
  4921. }
  4922.  
  4923. /* ffeste_V018_item -- REWRITE statement i/o item
  4924.  
  4925.    ffeste_V018_item(expr,expr_token);
  4926.  
  4927.    Implement output-list expression.  */
  4928.  
  4929. void
  4930. ffeste_V018_item (ffebld expr)
  4931. {
  4932.   ffeste_check_item_ ();
  4933.  
  4934. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4935.   ffebld_dump (expr);
  4936.   fputc (',', stdout);
  4937. #else
  4938. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4939. #endif
  4940. #endif
  4941. }
  4942.  
  4943. /* ffeste_V018_finish -- REWRITE statement list complete
  4944.  
  4945.    ffeste_V018_finish();
  4946.  
  4947.    Just wrap up any local activities.  */
  4948.  
  4949. void
  4950. ffeste_V018_finish ()
  4951. {
  4952.   ffeste_check_finish_ ();
  4953.  
  4954. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4955.   fputc ('\n', stdout);
  4956. #else
  4957. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4958. #endif
  4959. #endif
  4960. }
  4961.  
  4962. /* ffeste_V019_start -- ACCEPT statement list begin
  4963.  
  4964.    ffeste_V019_start();
  4965.  
  4966.    Verify that ACCEPT is valid here, and begin accepting items in the
  4967.    list.  */
  4968.  
  4969. void
  4970. ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
  4971. {
  4972.   ffeste_check_start_ ();
  4973.  
  4974. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  4975.   switch (format)
  4976.     {
  4977.     case FFESTV_formatLABEL:
  4978.     case FFESTV_formatCHAREXPR:
  4979.     case FFESTV_formatINTEXPR:
  4980.       fputs ("+ ACCEPT_fm ", stdout);
  4981.       break;
  4982.  
  4983.     case FFESTV_formatASTERISK:
  4984.       fputs ("+ ACCEPT_ls ", stdout);
  4985.       break;
  4986.  
  4987.     case FFESTV_formatNAMELIST:
  4988.       fputs ("+ ACCEPT_nl ", stdout);
  4989.       break;
  4990.  
  4991.     default:
  4992.       assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
  4993.     }
  4994.   ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
  4995.   fputc (' ', stdout);
  4996. #else
  4997. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4998. #endif
  4999. #endif
  5000. }
  5001.  
  5002. /* ffeste_V019_item -- ACCEPT statement i/o item
  5003.  
  5004.    ffeste_V019_item(expr,expr_token);
  5005.  
  5006.    Implement output-list expression.  */
  5007.  
  5008. void
  5009. ffeste_V019_item (ffebld expr)
  5010. {
  5011.   ffeste_check_item_ ();
  5012.  
  5013. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5014.   ffebld_dump (expr);
  5015.   fputc (',', stdout);
  5016. #else
  5017. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5018. #endif
  5019. #endif
  5020. }
  5021.  
  5022. /* ffeste_V019_finish -- ACCEPT statement list complete
  5023.  
  5024.    ffeste_V019_finish();
  5025.  
  5026.    Just wrap up any local activities.  */
  5027.  
  5028. void
  5029. ffeste_V019_finish ()
  5030. {
  5031.   ffeste_check_finish_ ();
  5032.  
  5033. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5034.   fputc ('\n', stdout);
  5035. #else
  5036. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5037. #endif
  5038. #endif
  5039. }
  5040.  
  5041. #endif
  5042. /* ffeste_V020_start -- TYPE statement list begin
  5043.  
  5044.    ffeste_V020_start();
  5045.  
  5046.    Verify that TYPE is valid here, and begin accepting items in the
  5047.    list.  */
  5048.  
  5049. void
  5050. ffeste_V020_start (ffestpTypeStmt *info, ffestvFormat format)
  5051. {
  5052.   ffeste_check_start_ ();
  5053.  
  5054. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5055.   switch (format)
  5056.     {
  5057.     case FFESTV_formatLABEL:
  5058.     case FFESTV_formatCHAREXPR:
  5059.     case FFESTV_formatINTEXPR:
  5060.       fputs ("+ TYPE_fm ", stdout);
  5061.       break;
  5062.  
  5063.     case FFESTV_formatASTERISK:
  5064.       fputs ("+ TYPE_ls ", stdout);
  5065.       break;
  5066.  
  5067.     case FFESTV_formatNAMELIST:
  5068.       fputs ("* TYPE_nl ", stdout);
  5069.       break;
  5070.  
  5071.     default:
  5072.       assert ("Unexpected kind of format item in V020 TYPE" == NULL);
  5073.     }
  5074.   ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
  5075.   fputc (' ', stdout);
  5076. #else
  5077. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5078. #endif
  5079. #endif
  5080. }
  5081.  
  5082. /* ffeste_V020_item -- TYPE statement i/o item
  5083.  
  5084.    ffeste_V020_item(expr,expr_token);
  5085.  
  5086.    Implement output-list expression.  */
  5087.  
  5088. void
  5089. ffeste_V020_item (ffebld expr)
  5090. {
  5091.   ffeste_check_item_ ();
  5092.  
  5093. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5094.   ffebld_dump (expr);
  5095.   fputc (',', stdout);
  5096. #else
  5097. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5098. #endif
  5099. #endif
  5100. }
  5101.  
  5102. /* ffeste_V020_finish -- TYPE statement list complete
  5103.  
  5104.    ffeste_V020_finish();
  5105.  
  5106.    Just wrap up any local activities.  */
  5107.  
  5108. void
  5109. ffeste_V020_finish ()
  5110. {
  5111.   ffeste_check_finish_ ();
  5112.  
  5113. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5114.   fputc ('\n', stdout);
  5115. #else
  5116. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5117. #endif
  5118. #endif
  5119. }
  5120.  
  5121. /* ffeste_V021 -- DELETE statement
  5122.  
  5123.    ffeste_V021();
  5124.  
  5125.    Make sure a DELETE is valid in the current context, and implement it.  */
  5126.  
  5127. #if FFESTR_VXT
  5128. void
  5129. ffeste_V021 (ffestpDeleteStmt *info)
  5130. {
  5131.   ffeste_check_simple_ ();
  5132.  
  5133. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5134.   fputs ("+ DELETE (", stdout);
  5135.   ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
  5136.   ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
  5137.   ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
  5138.   ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
  5139.   fputs (")\n", stdout);
  5140. #else
  5141. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5142. #endif
  5143. #endif
  5144. }
  5145.  
  5146. /* ffeste_V022 -- UNLOCK statement
  5147.  
  5148.    ffeste_V022();
  5149.  
  5150.    Make sure a UNLOCK is valid in the current context, and implement it.  */
  5151.  
  5152. void
  5153. ffeste_V022 (ffestpBeruStmt *info)
  5154. {
  5155.   ffeste_check_simple_ ();
  5156.  
  5157. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5158.   fputs ("+ UNLOCK (", stdout);
  5159.   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
  5160.   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
  5161.   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
  5162.   fputs (")\n", stdout);
  5163. #else
  5164. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5165. #endif
  5166. #endif
  5167. }
  5168.  
  5169. /* ffeste_V023_start -- ENCODE(...) statement list begin
  5170.  
  5171.    ffeste_V023_start();
  5172.  
  5173.    Verify that ENCODE is valid here, and begin accepting items in the
  5174.    list.  */
  5175.  
  5176. void
  5177. ffeste_V023_start (ffestpVxtcodeStmt *info)
  5178. {
  5179.   ffeste_check_start_ ();
  5180.  
  5181. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5182.   fputs ("+ ENCODE (", stdout);
  5183.   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
  5184.   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
  5185.   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
  5186.   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
  5187.   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
  5188.   fputs (") ", stdout);
  5189. #else
  5190. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5191. #endif
  5192. #endif
  5193. }
  5194.  
  5195. /* ffeste_V023_item -- ENCODE statement i/o item
  5196.  
  5197.    ffeste_V023_item(expr,expr_token);
  5198.  
  5199.    Implement output-list expression.  */
  5200.  
  5201. void
  5202. ffeste_V023_item (ffebld expr)
  5203. {
  5204.   ffeste_check_item_ ();
  5205.  
  5206. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5207.   ffebld_dump (expr);
  5208.   fputc (',', stdout);
  5209. #else
  5210. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5211. #endif
  5212. #endif
  5213. }
  5214.  
  5215. /* ffeste_V023_finish -- ENCODE statement list complete
  5216.  
  5217.    ffeste_V023_finish();
  5218.  
  5219.    Just wrap up any local activities.  */
  5220.  
  5221. void
  5222. ffeste_V023_finish ()
  5223. {
  5224.   ffeste_check_finish_ ();
  5225.  
  5226. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5227.   fputc ('\n', stdout);
  5228. #else
  5229. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5230. #endif
  5231. #endif
  5232. }
  5233.  
  5234. /* ffeste_V024_start -- DECODE(...) statement list begin
  5235.  
  5236.    ffeste_V024_start();
  5237.  
  5238.    Verify that DECODE is valid here, and begin accepting items in the
  5239.    list.  */
  5240.  
  5241. void
  5242. ffeste_V024_start (ffestpVxtcodeStmt *info)
  5243. {
  5244.   ffeste_check_start_ ();
  5245.  
  5246. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5247.   fputs ("+ DECODE (", stdout);
  5248.   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
  5249.   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
  5250.   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
  5251.   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
  5252.   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
  5253.   fputs (") ", stdout);
  5254. #else
  5255. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5256. #endif
  5257. #endif
  5258. }
  5259.  
  5260. /* ffeste_V024_item -- DECODE statement i/o item
  5261.  
  5262.    ffeste_V024_item(expr,expr_token);
  5263.  
  5264.    Implement output-list expression.  */
  5265.  
  5266. void
  5267. ffeste_V024_item (ffebld expr)
  5268. {
  5269.   ffeste_check_item_ ();
  5270.  
  5271. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5272.   ffebld_dump (expr);
  5273.   fputc (',', stdout);
  5274. #else
  5275. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5276. #endif
  5277. #endif
  5278. }
  5279.  
  5280. /* ffeste_V024_finish -- DECODE statement list complete
  5281.  
  5282.    ffeste_V024_finish();
  5283.  
  5284.    Just wrap up any local activities.  */
  5285.  
  5286. void
  5287. ffeste_V024_finish ()
  5288. {
  5289.   ffeste_check_finish_ ();
  5290.  
  5291. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5292.   fputc ('\n', stdout);
  5293. #else
  5294. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5295. #endif
  5296. #endif
  5297. }
  5298.  
  5299. /* ffeste_V025_start -- DEFINEFILE statement list begin
  5300.  
  5301.    ffeste_V025_start();
  5302.  
  5303.    Verify that DEFINEFILE is valid here, and begin accepting items in the
  5304.    list.  */
  5305.  
  5306. void
  5307. ffeste_V025_start ()
  5308. {
  5309.   ffeste_check_start_ ();
  5310.  
  5311. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5312.   fputs ("+ DEFINE_FILE ", stdout);
  5313. #else
  5314. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5315. #endif
  5316. #endif
  5317. }
  5318.  
  5319. /* ffeste_V025_item -- DEFINE FILE statement item
  5320.  
  5321.    ffeste_V025_item(u,ut,m,mt,n,nt,asv,asvt);
  5322.  
  5323.    Implement item.  */
  5324.  
  5325. void
  5326. ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
  5327. {
  5328.   ffeste_check_item_ ();
  5329.  
  5330. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5331.   ffebld_dump (u);
  5332.   fputc ('(', stdout);
  5333.   ffebld_dump (m);
  5334.   fputc (',', stdout);
  5335.   ffebld_dump (n);
  5336.   fputs (",U,", stdout);
  5337.   ffebld_dump (asv);
  5338.   fputs ("),", stdout);
  5339. #else
  5340. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5341. #endif
  5342. #endif
  5343. }
  5344.  
  5345. /* ffeste_V025_finish -- DEFINE FILE statement list complete
  5346.  
  5347.    ffeste_V025_finish();
  5348.  
  5349.    Just wrap up any local activities.  */
  5350.  
  5351. void
  5352. ffeste_V025_finish ()
  5353. {
  5354.   ffeste_check_finish_ ();
  5355.  
  5356. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5357.   fputc ('\n', stdout);
  5358. #else
  5359. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5360. #endif
  5361. #endif
  5362. }
  5363.  
  5364. /* ffeste_V026 -- FIND statement
  5365.  
  5366.    ffeste_V026();
  5367.  
  5368.    Make sure a FIND is valid in the current context, and implement it.    */
  5369.  
  5370. void
  5371. ffeste_V026 (ffestpFindStmt *info)
  5372. {
  5373.   ffeste_check_simple_ ();
  5374.  
  5375. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  5376.   fputs ("+ FIND (", stdout);
  5377.   ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
  5378.   ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
  5379.   ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
  5380.   ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
  5381.   fputs (")\n", stdout);
  5382. #else
  5383. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5384. #endif
  5385. #endif
  5386. }
  5387.  
  5388. #endif
  5389.