ste.c

gcc-2.95.3 Linux下最常用的C编译器

  clear_momentary ();

  ffecom_end_compstmt ();
}

/* Start a Fortran statement.

   Starts a back-end block, so temporaries can be managed, clean-ups
   properly handled, etc.  Nesting of statements *is* allowed -- the
   handling of I/O items, even implied-DO I/O lists, within a READ,
   PRINT, or WRITE statement is one example.  */

static void
ffeste_start_stmt_(void)
{
  gbe_block b = xmalloc (sizeof (*b));

  b->outer = ffeste_top_block_;
  b->block = NULL;
  b->lineno = lineno;
  b->input_filename = input_filename;
  b->is_stmt = TRUE;

  ffeste_top_block_ = b;

  ffecom_start_compstmt ();
}

/* End a Fortran statement.  */

static void
ffeste_end_stmt_(void)
{
  gbe_block b = ffeste_top_block_;

  assert (b);
  assert (b->is_stmt);

  ffeste_top_block_ = b->outer;

  free (b);

  clear_momentary ();

  ffecom_end_compstmt ();
}

#else  /* ! defined (ENABLE_CHECKING) */

#define ffeste_start_block_(b) ffecom_start_compstmt ()
#define ffeste_end_block_(b)	\
  do				\
    {				\
      clear_momentary ();	\
      ffecom_end_compstmt ();	\
    } while(0)
#define ffeste_start_stmt_() ffeste_start_block_(NULL)
#define ffeste_end_stmt_() ffeste_end_block_(NULL)

#endif  /* ! defined (ENABLE_CHECKING) */

/* Begin an iterative DO loop.  Pass the block to start if applicable.

   NOTE: Does _two_ push_momentary () calls, which the caller must
   undo (by calling ffeste_end_iterdo_).  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
		      tree *xitersvar, ffebld var,
		      ffebld start, ffelexToken start_token,
		      ffebld end, ffelexToken end_token,
		      ffebld incr, ffelexToken incr_token,
		      const char *msg)
{
  tree tvar;
  tree expr;
  tree tstart;
  tree tend;
  tree tincr;
  tree tincr_saved;
  tree niters;
  struct nesting *expanded_loop;

  /* Want to have tvar, tincr, and niters for the whole loop body. */

  if (block)
    ffeste_start_block_ (block);
  else
    ffeste_start_stmt_ ();

  niters = ffecom_make_tempvar (block ? "do" : "impdo",
				ffecom_integer_type_node,
				FFETARGET_charactersizeNONE, -1);

  ffecom_prepare_expr (incr);
  ffecom_prepare_expr_rw (NULL_TREE, var);

  ffecom_prepare_end ();

  tvar = ffecom_expr_rw (NULL_TREE, var);
  tincr = ffecom_expr (incr);

  if (TREE_CODE (tvar) == ERROR_MARK
      || TREE_CODE (tincr) == ERROR_MARK)
    {
      if (block)
	{
	  ffeste_end_block_ (block);
	  ffestw_set_do_tvar (block, error_mark_node);
	}
      else
	{
	  ffeste_end_stmt_ ();
	  *xtvar = error_mark_node;
	}
      return;
    }

  /* Check whether incr is known to be zero, complain and fix.  */

  if (integer_zerop (tincr) || real_zerop (tincr))
    {
      ffebad_start (FFEBAD_DO_STEP_ZERO);
      ffebad_here (0, ffelex_token_where_line (incr_token),
		   ffelex_token_where_column (incr_token));
      ffebad_string (msg);
      ffebad_finish ();
      tincr = convert (TREE_TYPE (tvar), integer_one_node);
    }

  tincr_saved = ffecom_save_tree (tincr);

  preserve_momentary ();

  /* Want to have tstart, tend for just this statement. */

  ffeste_start_stmt_ ();

  ffecom_prepare_expr (start);
  ffecom_prepare_expr (end);

  ffecom_prepare_end ();

  tstart = ffecom_expr (start);
  tend = ffecom_expr (end);

  if (TREE_CODE (tstart) == ERROR_MARK
      || TREE_CODE (tend) == ERROR_MARK)
    {
      ffeste_end_stmt_ ();

      if (block)
	{
	  ffeste_end_block_ (block);
	  ffestw_set_do_tvar (block, error_mark_node);
	}
      else
	{
	  ffeste_end_stmt_ ();
	  *xtvar = error_mark_node;
	}
      return;
    }

  /* For warnings only, nothing else happens here.  */
  {
    tree try;

    if (! ffe_is_onetrip ())
      {
	try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
			tend,
			tstart);

	try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
			try,
			tincr);

	if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
	  try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
			  tincr);
	else
	  try = convert (integer_type_node,
			 ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
				   try,
				   tincr));

	/* Warn if loop never executed, since we've done the evaluation
	   of the unofficial iteration count already.  */

	try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
					    try,
					    convert (TREE_TYPE (tvar),
						     integer_zero_node)));

	if (integer_onep (try))
	  {
	    ffebad_start (FFEBAD_DO_NULL);
	    ffebad_here (0, ffelex_token_where_line (start_token),
			 ffelex_token_where_column (start_token));
	    ffebad_string (msg);
	    ffebad_finish ();
	  }
      }

    /* Warn if end plus incr would overflow.  */

    try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
		    tend,
		    tincr);

    if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
	&& TREE_CONSTANT_OVERFLOW (try))
      {
	ffebad_start (FFEBAD_DO_END_OVERFLOW);
	ffebad_here (0, ffelex_token_where_line (end_token),
		     ffelex_token_where_column (end_token));
	ffebad_string (msg);
	ffebad_finish ();
      }
  }

  /* Do the initial assignment into the DO var.  */

  tstart = ffecom_save_tree (tstart);

  expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
		   tend,
		   tstart);

  if (! ffe_is_onetrip ())
    {
      expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
		       expr,
		       convert (TREE_TYPE (expr), tincr_saved));
    }

  if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
    expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
		     expr,
		     tincr_saved);
  else
    expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
		     expr,
		     tincr_saved);

#if 1	/* New, F90-approved approach: convert to default INTEGER. */
  if (TREE_TYPE (tvar) != error_mark_node)
    expr = convert (ffecom_integer_type_node, expr);
#else	/* Old approach; convert to INTEGER unless that's a narrowing. */
  if ((TREE_TYPE (tvar) != error_mark_node)
      && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
	  || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
	      && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
		   != INTEGER_CST)
		  || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
		      <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
    /* Convert unless promoting INTEGER type of any kind downward to
       default INTEGER; else leave as, say, INTEGER*8 (long long int).  */
    expr = convert (ffecom_integer_type_node, expr);
#endif

  assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
	  == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));

  expr = ffecom_modify (void_type_node, niters, expr);
  expand_expr_stmt (expr);

  expr = ffecom_modify (void_type_node, tvar, tstart);
  expand_expr_stmt (expr);

  ffeste_end_stmt_ ();

  expanded_loop = expand_start_loop_continue_elsewhere (!! block);
  if (block)
    ffestw_set_do_hook (block, expanded_loop);

  if (! ffe_is_onetrip ())
    {
      expr = ffecom_truth_value
	(ffecom_2 (GE_EXPR, integer_type_node,
		   ffecom_2 (PREDECREMENT_EXPR,
			     TREE_TYPE (niters),
			     niters,
			     convert (TREE_TYPE (niters),
				      ffecom_integer_one_node)),
		   convert (TREE_TYPE (niters),
			    ffecom_integer_zero_node)));

      expand_exit_loop_if_false (0, expr);
    }

  if (block)
    {
      ffestw_set_do_tvar (block, tvar);
      ffestw_set_do_incr_saved (block, tincr_saved);
      ffestw_set_do_count_var (block, niters);
    }
  else
    {
      *xtvar = tvar;
      *xtincr = tincr_saved;
      *xitersvar = niters;
    }
}

#endif

/* End an iterative DO loop.  Pass the same iteration variable and increment
   value trees that were generated in the paired _begin_ call.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
{
  tree expr;
  tree niters = itersvar;

  if (tvar == error_mark_node)
    return;

  expand_loop_continue_here ();

  ffeste_start_stmt_ ();

  if (ffe_is_onetrip ())
    {
      expr = ffecom_truth_value
	(ffecom_2 (GE_EXPR, integer_type_node,
		   ffecom_2 (PREDECREMENT_EXPR,
			     TREE_TYPE (niters),
			     niters,
			     convert (TREE_TYPE (niters),
				      ffecom_integer_one_node)),
		   convert (TREE_TYPE (niters),
			    ffecom_integer_zero_node)));

      expand_exit_loop_if_false (0, expr);
    }

  expr = ffecom_modify (void_type_node, tvar,
			ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
				  tvar,
				  tincr));
  expand_expr_stmt (expr);

  /* Lose the stuff we just built. */
  ffeste_end_stmt_ ();

  expand_end_loop ();

  /* Lose the tvar and incr_saved trees. */
  if (block)
    ffeste_end_block_ (block);
  else
    ffeste_end_stmt_ ();
}
#endif

/* Generate call to run-time I/O routine.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_io_call_ (tree call, bool do_check)
{
  /* Generate the call and optional assignment into iostat var. */

  TREE_SIDE_EFFECTS (call) = 1;
  if (ffeste_io_iostat_ != NULL_TREE)
    call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
			  ffeste_io_iostat_, call);
  expand_expr_stmt (call);

  if (! do_check
      || ffeste_io_abort_ == NULL_TREE
      || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
    return;

  /* Generate optional test. */

  expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
  expand_goto (ffeste_io_abort_);
  expand_end_cond ();
}
#endif

/* Handle implied-DO in I/O list.

   Expands code to start up the DO loop.  Then for each item in the
   DO loop, handles appropriately (possibly including recursively calling
   itself).  Then expands code to end the DO loop.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
{
  ffebld var = ffebld_head (ffebld_right (impdo));
  ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
  ffebld end = ffebld_head (ffebld_trail (ffebld_trail
					  (ffebld_right (impdo))));
  ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
				    (ffebld_trail (ffebld_right (impdo)))));
  ffebld list;
  ffebld item;
  tree tvar;
  tree tincr;
  tree titervar;

  if (incr == NULL)
    {
      incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
      ffebld_set_info (incr, ffeinfo_new
		       (FFEINFO_basictypeINTEGER,
			FFEINFO_kindtypeINTEGERDEFAULT,
			0,
			FFEINFO_kindENTITY,
			FFEINFO_whereCONSTANT,
			FFETARGET_charactersizeNONE));
    }

  /* Start the DO loop.  */

  start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
				FFEEXPR_contextLET);
  end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
			      FFEEXPR_contextLET);
  incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
			       FFEEXPR_contextLET);

  ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
			start, impdo_token,
			end, impdo_token,
			incr, impdo_token,
			"Implied DO loop");

  /* Handle the list of items.  */

  for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
    {
      item = ffebld_head (list);