trans-stmt.c

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

	 block_1
      CASE (190:199,200:)
	 block_2
      CASE (300)
	 block_3
      CASE DEFAULT
	 block_4
   END SELECT

   to the GENERIC equivalent,

     switch (expr)
       {
	 case (minimum value for typeof(expr) ... 100:
	 case 101:
	 case 105 ... 114:
	   block1:
	   goto end_label;

	 case 200 ... (maximum value for typeof(expr):
	 case 190 ... 199:
	   block2;
	   goto end_label;

	 case 300:
	   block_3;
	   goto end_label;

	 default:
	   block_4;
	   goto end_label;
       }

     end_label:  */

static tree
gfc_trans_integer_select (gfc_code * code)
{
  gfc_code *c;
  gfc_case *cp;
  tree end_label;
  tree tmp;
  gfc_se se;
  stmtblock_t block;
  stmtblock_t body;

  gfc_start_block (&block);

  /* Calculate the switch expression.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->expr);
  gfc_add_block_to_block (&block, &se.pre);

  end_label = gfc_build_label_decl (NULL_TREE);

  gfc_init_block (&body);

  for (c = code->block; c; c = c->block)
    {
      for (cp = c->ext.case_list; cp; cp = cp->next)
	{
	  tree low, high;
          tree label;

	  /* Assume it's the default case.  */
	  low = high = NULL_TREE;

	  if (cp->low)
	    {
	      low = gfc_conv_constant_to_tree (cp->low);

	      /* If there's only a lower bound, set the high bound to the
		 maximum value of the case expression.  */
	      if (!cp->high)
		high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
	    }

	  if (cp->high)
	    {
	      /* Three cases are possible here:

		 1) There is no lower bound, e.g. CASE (:N).
		 2) There is a lower bound .NE. high bound, that is
		    a case range, e.g. CASE (N:M) where M>N (we make
		    sure that M>N during type resolution).
		 3) There is a lower bound, and it has the same value
		    as the high bound, e.g. CASE (N:N).  This is our
		    internal representation of CASE(N).

		 In the first and second case, we need to set a value for
		 high.  In the thirth case, we don't because the GCC middle
		 end represents a single case value by just letting high be
		 a NULL_TREE.  We can't do that because we need to be able
		 to represent unbounded cases.  */

	      if (!cp->low
		  || (cp->low
		      && mpz_cmp (cp->low->value.integer,
				  cp->high->value.integer) != 0))
		high = gfc_conv_constant_to_tree (cp->high);

	      /* Unbounded case.  */
	      if (!cp->low)
		low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
	    }

          /* Build a label.  */
          label = gfc_build_label_decl (NULL_TREE);

	  /* Add this case label.
             Add parameter 'label', make it match GCC backend.  */
	  tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
	  gfc_add_expr_to_block (&body, tmp);
	}

      /* Add the statements for this case.  */
      tmp = gfc_trans_code (c->next);
      gfc_add_expr_to_block (&body, tmp);

      /* Break to the end of the construct.  */
      tmp = build1_v (GOTO_EXPR, end_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  tmp = gfc_finish_block (&body);
  tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
  gfc_add_expr_to_block (&block, tmp);

  tmp = build1_v (LABEL_EXPR, end_label);
  gfc_add_expr_to_block (&block, tmp);

  return gfc_finish_block (&block);
}


/* Translate the SELECT CASE construct for LOGICAL case expressions.

   There are only two cases possible here, even though the standard
   does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
   .FALSE., and DEFAULT.

   We never generate more than two blocks here.  Instead, we always
   try to eliminate the DEFAULT case.  This way, we can translate this
   kind of SELECT construct to a simple

   if {} else {};

   expression in GENERIC.  */

static tree
gfc_trans_logical_select (gfc_code * code)
{
  gfc_code *c;
  gfc_code *t, *f, *d;
  gfc_case *cp;
  gfc_se se;
  stmtblock_t block;

  /* Assume we don't have any cases at all.  */
  t = f = d = NULL;

  /* Now see which ones we actually do have.  We can have at most two
     cases in a single case list: one for .TRUE. and one for .FALSE.
     The default case is always separate.  If the cases for .TRUE. and
     .FALSE. are in the same case list, the block for that case list
     always executed, and we don't generate code a COND_EXPR.  */
  for (c = code->block; c; c = c->block)
    {
      for (cp = c->ext.case_list; cp; cp = cp->next)
	{
	  if (cp->low)
	    {
	      if (cp->low->value.logical == 0) /* .FALSE.  */
		f = c;
	      else /* if (cp->value.logical != 0), thus .TRUE.  */
		t = c;
	    }
	  else
	    d = c;
	}
    }

  /* Start a new block.  */
  gfc_start_block (&block);

  /* Calculate the switch expression.  We always need to do this
     because it may have side effects.  */
  gfc_init_se (&se, NULL);
  gfc_conv_expr_val (&se, code->expr);
  gfc_add_block_to_block (&block, &se.pre);

  if (t == f && t != NULL)
    {
      /* Cases for .TRUE. and .FALSE. are in the same block.  Just
         translate the code for these cases, append it to the current
         block.  */
      gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
    }
  else
    {
      tree true_tree, false_tree;

      true_tree = build_empty_stmt ();
      false_tree = build_empty_stmt ();

      /* If we have a case for .TRUE. and for .FALSE., discard the default case.
          Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
          make the missing case the default case.  */
      if (t != NULL && f != NULL)
	d = NULL;
      else if (d != NULL)
        {
	  if (t == NULL)
	    t = d;
	  else
	    f = d;
	}

      /* Translate the code for each of these blocks, and append it to
         the current block.  */
      if (t != NULL)
        true_tree = gfc_trans_code (t->next);

      if (f != NULL)
	false_tree = gfc_trans_code (f->next);

      gfc_add_expr_to_block (&block, build3_v (COND_EXPR, se.expr,
					       true_tree, false_tree));
    }

  return gfc_finish_block (&block);
}


/* Translate the SELECT CASE construct for CHARACTER case expressions.
   Instead of generating compares and jumps, it is far simpler to
   generate a data structure describing the cases in order and call a
   library subroutine that locates the right case.
   This is particularly true because this is the only case where we
   might have to dispose of a temporary.
   The library subroutine returns a pointer to jump to or NULL if no
   branches are to be taken.  */

static tree
gfc_trans_character_select (gfc_code *code)
{
  tree init, node, end_label, tmp, type, args, *labels;
  stmtblock_t block, body;
  gfc_case *cp, *d;
  gfc_code *c;
  gfc_se se;
  int i, n;

  static tree select_struct;
  static tree ss_string1, ss_string1_len;
  static tree ss_string2, ss_string2_len;
  static tree ss_target;

  if (select_struct == NULL)
    {
      tree gfc_int4_type_node = gfc_get_int_type (4);

      select_struct = make_node (RECORD_TYPE);
      TYPE_NAME (select_struct) = get_identifier ("_jump_struct");

#undef ADD_FIELD
#define ADD_FIELD(NAME, TYPE)				\
  ss_##NAME = gfc_add_field_to_struct			\
     (&(TYPE_FIELDS (select_struct)), select_struct,	\
      get_identifier (stringize(NAME)), TYPE)

      ADD_FIELD (string1, pchar_type_node);
      ADD_FIELD (string1_len, gfc_int4_type_node);

      ADD_FIELD (string2, pchar_type_node);
      ADD_FIELD (string2_len, gfc_int4_type_node);

      ADD_FIELD (target, pvoid_type_node);
#undef ADD_FIELD

      gfc_finish_type (select_struct);
    }

  cp = code->block->ext.case_list;
  while (cp->left != NULL)
    cp = cp->left;

  n = 0;
  for (d = cp; d; d = d->right)
    d->n = n++;

  if (n != 0)
    labels = gfc_getmem (n * sizeof (tree));
  else
    labels = NULL;

  for(i = 0; i < n; i++)
    {
      labels[i] = gfc_build_label_decl (NULL_TREE);
      TREE_USED (labels[i]) = 1;
      /* TODO: The gimplifier should do this for us, but it has
         inadequacies when dealing with static initializers.  */
      FORCED_LABEL (labels[i]) = 1;
    }

  end_label = gfc_build_label_decl (NULL_TREE);

  /* Generate the body */
  gfc_start_block (&block);
  gfc_init_block (&body);

  for (c = code->block; c; c = c->block)
    {
      for (d = c->ext.case_list; d; d = d->next)
        {
          tmp = build1_v (LABEL_EXPR, labels[d->n]);
          gfc_add_expr_to_block (&body, tmp);
        }

      tmp = gfc_trans_code (c->next);
      gfc_add_expr_to_block (&body, tmp);

      tmp = build1_v (GOTO_EXPR, end_label);
      gfc_add_expr_to_block (&body, tmp);
    }

  /* Generate the structure describing the branches */
  init = NULL_TREE;
  i = 0;

  for(d = cp; d; d = d->right, i++)
    {
      node = NULL_TREE;

      gfc_init_se (&se, NULL);

      if (d->low == NULL)
        {
          node = tree_cons (ss_string1, null_pointer_node, node);
          node = tree_cons (ss_string1_len, integer_zero_node, node);
        }
      else
        {
          gfc_conv_expr_reference (&se, d->low);

          node = tree_cons (ss_string1, se.expr, node);
          node = tree_cons (ss_string1_len, se.string_length, node);
        }

      if (d->high == NULL)
        {
          node = tree_cons (ss_string2, null_pointer_node, node);
          node = tree_cons (ss_string2_len, integer_zero_node, node);
        }
      else
        {
          gfc_init_se (&se, NULL);
          gfc_conv_expr_reference (&se, d->high);

          node = tree_cons (ss_string2, se.expr, node);
          node = tree_cons (ss_string2_len, se.string_length, node);
        }

      tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
      node = tree_cons (ss_target, tmp, node);

      tmp = build_constructor_from_list (select_struct, nreverse (node));
      init = tree_cons (NULL_TREE, tmp, init);
    }

  type = build_array_type (select_struct, build_index_type
			   (build_int_cst (NULL_TREE, n - 1)));

  init = build_constructor_from_list (type, nreverse(init));
  TREE_CONSTANT (init) = 1;
  TREE_INVARIANT (init) = 1;
  TREE_STATIC (init) = 1;
  /* Create a static variable to hold the jump table.  */
  tmp = gfc_create_var (type, "jumptable");
  TREE_CONSTANT (tmp) = 1;
  TREE_INVARIANT (tmp) = 1;
  TREE_STATIC (tmp) = 1;
  DECL_INITIAL (tmp) = init;
  init = tmp;

  /* Build an argument list for the library call */
  init = gfc_build_addr_expr (pvoid_type_node, init);
  args = gfc_chainon_list (NULL_TREE, init);

  tmp = build_int_cst (NULL_TREE, n);
  args = gfc_chainon_list (args, tmp);

  tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
  args = gfc_chainon_list (args, tmp);

  gfc_init_se (&se, NULL);
  gfc_conv_expr_reference (&se, code->expr);

  args = gfc_chainon_list (args, se.expr);
  args = gfc_chainon_list (args, se.string_length);

  gfc_add_block_to_block (&block, &se.pre);

  tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
  tmp = build1 (GOTO_EXPR, void_type_node, tmp);
  gfc_add_expr_to_block (&block, tmp);

  tmp = gfc_finish_block (&body);
  gfc_add_expr_to_block (&block, tmp);
  tmp = build1_v (LABEL_EXPR, end_label);
  gfc_add_expr_to_block (&block, tmp);

  if (n != 0)
    gfc_free (labels);

  return gfc_finish_block (&block);
}


/* Translate the three variants of the SELECT CASE construct.

   SELECT CASEs with INTEGER case expressions can be translated to an
   equivalent GENERIC switch statement, and for LOGICAL case
   expressions we build one or two if-else compares.

   SELECT CASEs with CHARACTER case expressions are a whole different
   story, because they don't exist in GENERIC.  So we sort them and
   do a binary search at runtime.

   Fortran has no BREAK statement, and it does not allow jumps from
   one case block to another.  That makes things a lot easier for
   the optimizers.  */

tree
gfc_trans_select (gfc_code * code)
{
  gcc_assert (code && code->expr);

  /* Empty SELECT constructs are legal.  */
  if (code->block == NULL)
    return build_empty_stmt ();

  /* Select the correct translation function.  */
  switch (code->expr->ts.type)
    {
    case BT_LOGICAL:	return gfc_trans_logical_select (code);
    case BT_INTEGER:	return gfc_trans_integer_select (code);
    case BT_CHARACTER:	return gfc_trans_character_select (code);
    default:
      gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
      /* Not reached */
    }
}


/* Generate the loops for a FORALL block.  The normal loop format:
    count = (end - start + step) / step
    loopvar = start
    while (1)
      {
        if (count <=0 )
          goto end_of_loop
        <body>
        loopvar += step
        count --
      }
    end_of_loop:  */