trans-stmt.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

  /* Check for an unconditional ELSE clause.  */
  if (!code->expr)
    return gfc_trans_code (code->next);

  /* Initialize a statement builder for each block. Puts in NULL_TREEs.  */
  gfc_init_se (&if_se, NULL);
  gfc_start_block (&if_se.pre);

  /* Calculate the IF condition expression.  */
  gfc_conv_expr_val (&if_se, code->expr);

  /* Translate the THEN clause.  */
  stmt = gfc_trans_code (code->next);

  /* Translate the ELSE clause.  */
  if (code->block)
    elsestmt = gfc_trans_if_1 (code->block);
  else
    elsestmt = build_empty_stmt ();

  /* Build the condition expression and add it to the condition block.  */
  stmt = build3_v (COND_EXPR, if_se.expr, stmt, elsestmt);
  
  gfc_add_expr_to_block (&if_se.pre, stmt);

  /* Finish off this statement.  */
  return gfc_finish_block (&if_se.pre);
}

tree
gfc_trans_if (gfc_code * code)
{
  /* Ignore the top EXEC_IF, it only announces an IF construct. The
     actual code we must translate is in code->block.  */

  return gfc_trans_if_1 (code->block);
}


/* Translage an arithmetic IF expression.

   IF (cond) label1, label2, label3 translates to

    if (cond <= 0)
      {
        if (cond < 0)
          goto label1;
        else // cond == 0
          goto label2;
      }
    else // cond > 0
      goto label3;

   An optimized version can be generated in case of equal labels.
   E.g., if label1 is equal to label2, we can translate it to

    if (cond <= 0)
      goto label1;
    else
      goto label3;
*/

tree
gfc_trans_arithmetic_if (gfc_code * code)
{
  gfc_se se;
  tree tmp;
  tree branch1;
  tree branch2;
  tree zero;

  /* Start a new block.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  /* Pre-evaluate COND.  */
  gfc_conv_expr_val (&se, code->expr);

  /* Build something to compare with.  */
  zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);

  if (code->label->value != code->label2->value)
    {
      /* If (cond < 0) take branch1 else take branch2.
         First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases.  */
      branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));

      if (code->label->value != code->label3->value)
        tmp = build2 (LT_EXPR, boolean_type_node, se.expr, zero);
      else
        tmp = build2 (NE_EXPR, boolean_type_node, se.expr, zero);

      branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
    }
  else
    branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));

  if (code->label->value != code->label3->value
      && code->label2->value != code->label3->value)
    {
      /* if (cond <= 0) take branch1 else take branch2.  */
      branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
      tmp = build2 (LE_EXPR, boolean_type_node, se.expr, zero);
      branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
    }

  /* Append the COND_EXPR to the evaluation of COND, and return.  */
  gfc_add_expr_to_block (&se.pre, branch1);
  return gfc_finish_block (&se.pre);
}


/* Translate the simple DO construct.  This is where the loop variable has
   integer type and step +-1.  We can't use this in the general case
   because integer overflow and floating point errors could give incorrect
   results.
   We translate a do loop from:

   DO dovar = from, to, step
      body
   END DO

   to:

   [Evaluate loop bounds and step]
   dovar = from;
   if ((step > 0) ? (dovar <= to) : (dovar => to))
    {
      for (;;)
        {
	  body;
   cycle_label:
	  cond = (dovar == to);
	  dovar += step;
	  if (cond) goto end_label;
	}
      }
   end_label:

   This helps the optimizers by avoiding the extra induction variable
   used in the general case.  */

static tree
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
		     tree from, tree to, tree step)
{
  stmtblock_t body;
  tree type;
  tree cond;
  tree tmp;
  tree cycle_label;
  tree exit_label;
  
  type = TREE_TYPE (dovar);

  /* Initialize the DO variable: dovar = from.  */
  gfc_add_modify_expr (pblock, dovar, from);

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);

  /* Put the labels where they can be found later. See gfc_trans_do().  */
  code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);

  /* Loop body.  */
  gfc_start_block (&body);

  /* Main loop body.  */
  tmp = gfc_trans_code (code->block->next);
  gfc_add_expr_to_block (&body, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Evaluate the loop condition.  */
  cond = build2 (EQ_EXPR, boolean_type_node, dovar, to);
  cond = gfc_evaluate_now (cond, &body);

  /* Increment the loop variable.  */
  tmp = build2 (PLUS_EXPR, type, dovar, step);
  gfc_add_modify_expr (&body, dovar, tmp);

  /* The loop exit.  */
  tmp = build1_v (GOTO_EXPR, exit_label);
  TREE_USED (exit_label) = 1;
  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
  gfc_add_expr_to_block (&body, tmp);

  /* Finish the loop body.  */
  tmp = gfc_finish_block (&body);
  tmp = build1_v (LOOP_EXPR, tmp);

  /* Only execute the loop if the number of iterations is positive.  */
  if (tree_int_cst_sgn (step) > 0)
    cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
  else
    cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
  gfc_add_expr_to_block (pblock, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (pblock, tmp);

  return gfc_finish_block (pblock);
}

/* Translate the DO construct.  This obviously is one of the most
   important ones to get right with any compiler, but especially
   so for Fortran.

   We special case some loop forms as described in gfc_trans_simple_do.
   For other cases we implement them with a separate loop count,
   as described in the standard.

   We translate a do loop from:

   DO dovar = from, to, step
      body
   END DO

   to:

   [evaluate loop bounds and step]
   count = to + step - from;
   dovar = from;
   for (;;)
     {
       body;
cycle_label:
       dovar += step
       count--;
       if (count <=0) goto exit_label;
     }
exit_label:

   TODO: Large loop counts
   The code above assumes the loop count fits into a signed integer kind,
   i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
   We must support the full range.  */

tree
gfc_trans_do (gfc_code * code)
{
  gfc_se se;
  tree dovar;
  tree from;
  tree to;
  tree step;
  tree count;
  tree count_one;
  tree type;
  tree cond;
  tree cycle_label;
  tree exit_label;
  tree tmp;
  stmtblock_t block;
  stmtblock_t body;

  gfc_start_block (&block);

  /* Evaluate all the expressions in the iterator.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_lhs (&se, code->ext.iterator->var);
  gfc_add_block_to_block (&block, &se.pre);
  dovar = se.expr;
  type = TREE_TYPE (dovar);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->start);
  gfc_add_block_to_block (&block, &se.pre);
  from = gfc_evaluate_now (se.expr, &block);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->end);
  gfc_add_block_to_block (&block, &se.pre);
  to = gfc_evaluate_now (se.expr, &block);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->ext.iterator->step);
  gfc_add_block_to_block (&block, &se.pre);
  step = gfc_evaluate_now (se.expr, &block);

  /* Special case simple loops.  */
  if (TREE_CODE (type) == INTEGER_TYPE
      && (integer_onep (step)
	|| tree_int_cst_equal (step, integer_minus_one_node)))
    return gfc_trans_simple_do (code, &block, dovar, from, to, step);
      
  /* Initialize loop count. This code is executed before we enter the
     loop body. We generate: count = (to + step - from) / step.  */

  tmp = fold_build2 (MINUS_EXPR, type, step, from);
  tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
  if (TREE_CODE (type) == INTEGER_TYPE)
    {
      tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
      count = gfc_create_var (type, "count");
    }
  else
    {
      /* TODO: We could use the same width as the real type.
	 This would probably cause more problems that it solves
	 when we implement "long double" types.  */
      tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
      tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
      count = gfc_create_var (gfc_array_index_type, "count");
    }
  gfc_add_modify_expr (&block, count, tmp);

  count_one = convert (TREE_TYPE (count), integer_one_node);

  /* Initialize the DO variable: dovar = from.  */
  gfc_add_modify_expr (&block, dovar, from);

  /* Loop body.  */
  gfc_start_block (&body);

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);

  /* Start with the loop condition.  Loop until count <= 0.  */
  cond = build2 (LE_EXPR, boolean_type_node, count,
		convert (TREE_TYPE (count), integer_zero_node));
  tmp = build1_v (GOTO_EXPR, exit_label);
  TREE_USED (exit_label) = 1;
  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
  gfc_add_expr_to_block (&body, tmp);

  /* Put these labels where they can be found later. We put the
     labels in a TREE_LIST node (because TREE_CHAIN is already
     used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
     label in TREE_VALUE (backend_decl).  */

  code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);

  /* Main loop body.  */
  tmp = gfc_trans_code (code->block->next);
  gfc_add_expr_to_block (&body, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Increment the loop variable.  */
  tmp = build2 (PLUS_EXPR, type, dovar, step);
  gfc_add_modify_expr (&body, dovar, tmp);

  /* Decrement the loop count.  */
  tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
  gfc_add_modify_expr (&body, count, tmp);

  /* End of loop body.  */
  tmp = gfc_finish_block (&body);

  /* The for loop itself.  */
  tmp = build1_v (LOOP_EXPR, tmp);
  gfc_add_expr_to_block (&block, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the DO WHILE construct.

   We translate

   DO WHILE (cond)
      body
   END DO

   to:

   for ( ; ; )
     {
       pre_cond;
       if (! cond) goto exit_label;
       body;
cycle_label:
     }
exit_label:

   Because the evaluation of the exit condition `cond' may have side
   effects, we can't do much for empty loop bodies.  The backend optimizers
   should be smart enough to eliminate any dead loops.  */

tree
gfc_trans_do_while (gfc_code * code)
{
  gfc_se cond;
  tree tmp;
  tree cycle_label;
  tree exit_label;
  stmtblock_t block;

  /* Everything we build here is part of the loop body.  */
  gfc_start_block (&block);

  /* Cycle and exit statements are implemented with gotos.  */
  cycle_label = gfc_build_label_decl (NULL_TREE);
  exit_label = gfc_build_label_decl (NULL_TREE);

  /* Put the labels where they can be found later. See gfc_trans_do().  */
  code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);

  /* Create a GIMPLE version of the exit condition.  */
  gfc_init_se (&cond, NULL);
  gfc_conv_expr_val (&cond, code->expr);
  gfc_add_block_to_block (&block, &cond.pre);
  cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);

  /* Build "IF (! cond) GOTO exit_label".  */
  tmp = build1_v (GOTO_EXPR, exit_label);
  TREE_USED (exit_label) = 1;
  tmp = build3_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
  gfc_add_expr_to_block (&block, tmp);

  /* The main body of the loop.  */
  tmp = gfc_trans_code (code->block->next);
  gfc_add_expr_to_block (&block, tmp);

  /* Label for cycle statements (if needed).  */
  if (TREE_USED (cycle_label))
    {
      tmp = build1_v (LABEL_EXPR, cycle_label);
      gfc_add_expr_to_block (&block, tmp);
    }

  /* End of loop body.  */
  tmp = gfc_finish_block (&block);

  gfc_init_block (&block);
  /* Build the loop.  */
  tmp = build1_v (LOOP_EXPR, tmp);
  gfc_add_expr_to_block (&block, tmp);

  /* Add the exit label.  */
  tmp = build1_v (LABEL_EXPR, exit_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the SELECT CASE construct for INTEGER case expressions,
   without killing all potential optimizations.  The problem is that
   Fortran allows unbounded cases, but the back-end does not, so we
   need to intercept those before we enter the equivalent SWITCH_EXPR
   we can build.

   For example, we translate this,

   SELECT CASE (expr)
      CASE (:100,101,105:115)