trans-stmt.c

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

/* Statement translation -- generate GCC trees from gfc_code.
   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Paul Brook <[e-mail]>
   and Steven Bosscher <[e-mail]>

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"

typedef struct iter_info
{
  tree var;
  tree start;
  tree end;
  tree step;
  struct iter_info *next;
}
iter_info;

typedef  struct temporary_list
{
  tree temporary;
  struct temporary_list *next;
}
temporary_list;

typedef struct forall_info
{
  iter_info *this_loop;
  tree mask;
  tree pmask;
  tree maskindex;
  int nvar;
  tree size;
  struct forall_info  *outer;
  struct forall_info  *next_nest;
}
forall_info;

static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
                               stmtblock_t *, temporary_list **temp);

/* Translate a F95 label number to a LABEL_EXPR.  */

tree
gfc_trans_label_here (gfc_code * code)
{
  return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}


/* Given a variable expression which has been ASSIGNed to, find the decl
   containing the auxiliary variables.  For variables in common blocks this
   is a field_decl.  */

void
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
{
  gcc_assert (expr->symtree->n.sym->attr.assign == 1);
  gfc_conv_expr (se, expr);
  /* Deals with variable in common block. Get the field declaration.  */
  if (TREE_CODE (se->expr) == COMPONENT_REF)
    se->expr = TREE_OPERAND (se->expr, 1);
  /* Deals with dummy argument. Get the parameter declaration.  */
  else if (TREE_CODE (se->expr) == INDIRECT_REF)
    se->expr = TREE_OPERAND (se->expr, 0);
}

/* Translate a label assignment statement.  */

tree
gfc_trans_label_assign (gfc_code * code)
{
  tree label_tree;
  gfc_se se;
  tree len;
  tree addr;
  tree len_tree;
  char *label_str;
  int label_len;

  /* Start a new block.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  gfc_conv_label_variable (&se, code->expr);

  len = GFC_DECL_STRING_LEN (se.expr);
  addr = GFC_DECL_ASSIGN_ADDR (se.expr);

  label_tree = gfc_get_label_decl (code->label);

  if (code->label->defined == ST_LABEL_TARGET)
    {
      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
      len_tree = integer_minus_one_node;
    }
  else
    {
      label_str = code->label->format->value.character.string;
      label_len = code->label->format->value.character.length;
      len_tree = build_int_cst (NULL_TREE, label_len);
      label_tree = gfc_build_string_const (label_len + 1, label_str);
      label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
    }

  gfc_add_modify_expr (&se.pre, len, len_tree);
  gfc_add_modify_expr (&se.pre, addr, label_tree);

  return gfc_finish_block (&se.pre);
}

/* Translate a GOTO statement.  */

tree
gfc_trans_goto (gfc_code * code)
{
  tree assigned_goto;
  tree target;
  tree tmp;
  tree assign_error;
  tree range_error;
  gfc_se se;


  if (code->label != NULL)
    return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));

  /* ASSIGNED GOTO.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);
  gfc_conv_label_variable (&se, code->expr);
  assign_error =
    gfc_build_cstring_const ("Assigned label is not a target label");
  tmp = GFC_DECL_STRING_LEN (se.expr);
  tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
  gfc_trans_runtime_check (tmp, assign_error, &se.pre);

  assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);

  code = code->block;
  if (code == NULL)
    {
      target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
      gfc_add_expr_to_block (&se.pre, target);
      return gfc_finish_block (&se.pre);
    }

  /* Check the label list.  */
  range_error = gfc_build_cstring_const ("Assigned label is not in the list");

  do
    {
      target = gfc_get_label_decl (code->label);
      tmp = gfc_build_addr_expr (pvoid_type_node, target);
      tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
      tmp = build3_v (COND_EXPR, tmp,
		      build1 (GOTO_EXPR, void_type_node, target),
		      build_empty_stmt ());
      gfc_add_expr_to_block (&se.pre, tmp);
      code = code->block;
    }
  while (code != NULL);
  gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
  return gfc_finish_block (&se.pre); 
}


/* Translate an ENTRY statement.  Just adds a label for this entry point.  */
tree
gfc_trans_entry (gfc_code * code)
{
  return build1_v (LABEL_EXPR, code->ext.entry->label);
}


/* Translate the CALL statement.  Builds a call to an F95 subroutine.  */

tree
gfc_trans_call (gfc_code * code)
{
  gfc_se se;
  gfc_ss * ss;
  int has_alternate_specifier;

  /* A CALL starts a new block because the actual arguments may have to
     be evaluated first.  */
  gfc_init_se (&se, NULL);
  gfc_start_block (&se.pre);

  gcc_assert (code->resolved_sym);

  ss = gfc_ss_terminator;
  if (code->resolved_sym->attr.elemental)
    ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);

  /* Is not an elemental subroutine call with array valued arguments.  */
  if (ss == gfc_ss_terminator)
    {

      /* Translate the call.  */
      has_alternate_specifier
	= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);

      /* A subroutine without side-effect, by definition, does nothing!  */
      TREE_SIDE_EFFECTS (se.expr) = 1;

      /* Chain the pieces together and return the block.  */
      if (has_alternate_specifier)
	{
	  gfc_code *select_code;
	  gfc_symbol *sym;
	  select_code = code->next;
	  gcc_assert(select_code->op == EXEC_SELECT);
	  sym = select_code->expr->symtree->n.sym;
	  se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
	  gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
	}
      else
	gfc_add_expr_to_block (&se.pre, se.expr);

      gfc_add_block_to_block (&se.pre, &se.post);
    }

  else
    {
      /* An elemental subroutine call with array valued arguments has
	 to be scalarized.  */
      gfc_loopinfo loop;
      stmtblock_t body;
      stmtblock_t block;
      gfc_se loopse;

      /* gfc_walk_elemental_function_args renders the ss chain in the
         reverse order to the actual argument order.  */
      ss = gfc_reverse_ss (ss);

      /* Initialize the loop.  */
      gfc_init_se (&loopse, NULL);
      gfc_init_loopinfo (&loop);
      gfc_add_ss_to_loop (&loop, ss);

      gfc_conv_ss_startstride (&loop);
      gfc_conv_loop_setup (&loop);
      gfc_mark_ss_chain_used (ss, 1);

      /* Generate the loop body.  */
      gfc_start_scalarized_body (&loop, &body);
      gfc_init_block (&block);
      gfc_copy_loopinfo_to_se (&loopse, &loop);
      loopse.ss = ss;

      /* Add the subroutine call to the block.  */
      gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
      gfc_add_expr_to_block (&loopse.pre, loopse.expr);

      gfc_add_block_to_block (&block, &loopse.pre);
      gfc_add_block_to_block (&block, &loopse.post);

      /* Finish up the loop block and the loop.  */
      gfc_add_expr_to_block (&body, gfc_finish_block (&block));
      gfc_trans_scalarizing_loops (&loop, &body);
      gfc_add_block_to_block (&se.pre, &loop.pre);
      gfc_add_block_to_block (&se.pre, &loop.post);
      gfc_cleanup_loop (&loop);
    }

  return gfc_finish_block (&se.pre);
}


/* Translate the RETURN statement.  */

tree
gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
{
  if (code->expr)
    {
      gfc_se se;
      tree tmp;
      tree result;

      /* if code->expr is not NULL, this return statement must appear
         in a subroutine and current_fake_result_decl has already
	 been generated.  */

      result = gfc_get_fake_result_decl (NULL);
      if (!result)
        {
          gfc_warning ("An alternate return at %L without a * dummy argument",
                        &code->expr->where);
          return build1_v (GOTO_EXPR, gfc_get_return_label ());
        }

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

      gfc_conv_expr (&se, code->expr);

      tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
      gfc_add_expr_to_block (&se.pre, tmp);

      tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
      gfc_add_expr_to_block (&se.pre, tmp);
      gfc_add_block_to_block (&se.pre, &se.post);
      return gfc_finish_block (&se.pre);
    }
  else
    return build1_v (GOTO_EXPR, gfc_get_return_label ());
}


/* Translate the PAUSE statement.  We have to translate this statement
   to a runtime library call.  */

tree
gfc_trans_pause (gfc_code * code)
{
  tree gfc_int4_type_node = gfc_get_int_type (4);
  gfc_se se;
  tree args;
  tree tmp;
  tree fndecl;

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


  if (code->expr == NULL)
    {
      tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
      args = gfc_chainon_list (NULL_TREE, tmp);
      fndecl = gfor_fndecl_pause_numeric;
    }
  else
    {
      gfc_conv_expr_reference (&se, code->expr);
      args = gfc_chainon_list (NULL_TREE, se.expr);
      args = gfc_chainon_list (args, se.string_length);
      fndecl = gfor_fndecl_pause_string;
    }

  tmp = gfc_build_function_call (fndecl, args);
  gfc_add_expr_to_block (&se.pre, tmp);

  gfc_add_block_to_block (&se.pre, &se.post);

  return gfc_finish_block (&se.pre);
}


/* Translate the STOP statement.  We have to translate this statement
   to a runtime library call.  */

tree
gfc_trans_stop (gfc_code * code)
{
  tree gfc_int4_type_node = gfc_get_int_type (4);
  gfc_se se;
  tree args;
  tree tmp;
  tree fndecl;

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


  if (code->expr == NULL)
    {
      tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
      args = gfc_chainon_list (NULL_TREE, tmp);
      fndecl = gfor_fndecl_stop_numeric;
    }
  else
    {
      gfc_conv_expr_reference (&se, code->expr);
      args = gfc_chainon_list (NULL_TREE, se.expr);
      args = gfc_chainon_list (args, se.string_length);
      fndecl = gfor_fndecl_stop_string;
    }

  tmp = gfc_build_function_call (fndecl, args);
  gfc_add_expr_to_block (&se.pre, tmp);

  gfc_add_block_to_block (&se.pre, &se.post);

  return gfc_finish_block (&se.pre);
}


/* Generate GENERIC for the IF construct. This function also deals with
   the simple IF statement, because the front end translates the IF
   statement into an IF construct.

   We translate:

        IF (cond) THEN
           then_clause
        ELSEIF (cond2)
           elseif_clause
        ELSE
           else_clause
        ENDIF

   into:

        pre_cond_s;
        if (cond_s)
          {
            then_clause;
          }
        else
          {
            pre_cond_s
            if (cond_s)
              {
                elseif_clause
              }
            else
              {
                else_clause;
              }
          }

   where COND_S is the simplified version of the predicate. PRE_COND_S
   are the pre side-effects produced by the translation of the
   conditional.
   We need to build the chain recursively otherwise we run into
   problems with folding incomplete statements.  */

static tree
gfc_trans_if_1 (gfc_code * code)
{
  gfc_se if_se;
  tree stmt, elsestmt;