trans-expr.c

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

/* Expression translation
   Copyright (C) 2002, 2003, 2004, 2005, 2006 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.  */

/* trans-expr.c-- generate GENERIC trees for gfc_expr.  */

#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "convert.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "tree-gimple.h"
#include "flags.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
#include "trans-stmt.h"
#include "dependency.h"

static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
						 gfc_expr *);

/* Copy the scalarization loop variables.  */

static void
gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
{
  dest->ss = src->ss;
  dest->loop = src->loop;
}


/* Initialize a simple expression holder.

   Care must be taken when multiple se are created with the same parent.
   The child se must be kept in sync.  The easiest way is to delay creation
   of a child se until after after the previous se has been translated.  */

void
gfc_init_se (gfc_se * se, gfc_se * parent)
{
  memset (se, 0, sizeof (gfc_se));
  gfc_init_block (&se->pre);
  gfc_init_block (&se->post);

  se->parent = parent;

  if (parent)
    gfc_copy_se_loopvars (se, parent);
}


/* Advances to the next SS in the chain.  Use this rather than setting
   se->ss = se->ss->next because all the parents needs to be kept in sync.
   See gfc_init_se.  */

void
gfc_advance_se_ss_chain (gfc_se * se)
{
  gfc_se *p;

  gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);

  p = se;
  /* Walk down the parent chain.  */
  while (p != NULL)
    {
      /* Simple consistency check.  */
      gcc_assert (p->parent == NULL || p->parent->ss == p->ss);

      p->ss = p->ss->next;

      p = p->parent;
    }
}


/* Ensures the result of the expression as either a temporary variable
   or a constant so that it can be used repeatedly.  */

void
gfc_make_safe_expr (gfc_se * se)
{
  tree var;

  if (CONSTANT_CLASS_P (se->expr))
    return;

  /* We need a temporary for this result.  */
  var = gfc_create_var (TREE_TYPE (se->expr), NULL);
  gfc_add_modify_expr (&se->pre, var, se->expr);
  se->expr = var;
}


/* Return an expression which determines if a dummy parameter is present.
   Also used for arguments to procedures with multiple entry points.  */

tree
gfc_conv_expr_present (gfc_symbol * sym)
{
  tree decl;

  gcc_assert (sym->attr.dummy);

  decl = gfc_get_symbol_decl (sym);
  if (TREE_CODE (decl) != PARM_DECL)
    {
      /* Array parameters use a temporary descriptor, we want the real
         parameter.  */
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
             || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
      decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
    }
  return build2 (NE_EXPR, boolean_type_node, decl,
		 fold_convert (TREE_TYPE (decl), null_pointer_node));
}


/* Get the character length of an expression, looking through gfc_refs
   if necessary.  */

tree
gfc_get_expr_charlen (gfc_expr *e)
{
  gfc_ref *r;
  tree length;

  gcc_assert (e->expr_type == EXPR_VARIABLE 
	      && e->ts.type == BT_CHARACTER);
  
  length = NULL; /* To silence compiler warning.  */

  /* First candidate: if the variable is of type CHARACTER, the
     expression's length could be the length of the character
     variable.  */
  if (e->symtree->n.sym->ts.type == BT_CHARACTER)
    length = e->symtree->n.sym->ts.cl->backend_decl;

  /* Look through the reference chain for component references.  */
  for (r = e->ref; r; r = r->next)
    {
      switch (r->type)
	{
	case REF_COMPONENT:
	  if (r->u.c.component->ts.type == BT_CHARACTER)
	    length = r->u.c.component->ts.cl->backend_decl;
	  break;

	case REF_ARRAY:
	  /* Do nothing.  */
	  break;

	default:
	  /* We should never got substring references here.  These will be
	     broken down by the scalarizer.  */
	  gcc_unreachable ();
	}
    }

  gcc_assert (length != NULL);
  return length;
}

  

/* Generate code to initialize a string length variable. Returns the
   value.  */

void
gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
{
  gfc_se se;
  tree tmp;

  gfc_init_se (&se, NULL);
  gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
  gfc_add_block_to_block (pblock, &se.pre);

  tmp = cl->backend_decl;
  gfc_add_modify_expr (pblock, tmp, se.expr);
}


static void
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
{
  tree tmp;
  tree type;
  tree var;
  gfc_se start;
  gfc_se end;

  type = gfc_get_character_type (kind, ref->u.ss.length);
  type = build_pointer_type (type);

  var = NULL_TREE;
  gfc_init_se (&start, se);
  gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
  gfc_add_block_to_block (&se->pre, &start.pre);

  if (integer_onep (start.expr))
    gfc_conv_string_parameter (se);
  else
    {
      /* Change the start of the string.  */
      if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
	tmp = se->expr;
      else
	tmp = gfc_build_indirect_ref (se->expr);
      tmp = gfc_build_array_ref (tmp, start.expr);
      se->expr = gfc_build_addr_expr (type, tmp);
    }

  /* Length = end + 1 - start.  */
  gfc_init_se (&end, se);
  if (ref->u.ss.end == NULL)
    end.expr = se->string_length;
  else
    {
      gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
      gfc_add_block_to_block (&se->pre, &end.pre);
    }
  tmp =
    build2 (MINUS_EXPR, gfc_charlen_type_node,
	    fold_convert (gfc_charlen_type_node, integer_one_node),
	    start.expr);
  tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
  se->string_length = fold (tmp);
}


/* Convert a derived type component reference.  */

static void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
  gfc_component *c;
  tree tmp;
  tree decl;
  tree field;

  c = ref->u.c.component;

  gcc_assert (c->backend_decl);

  field = c->backend_decl;
  gcc_assert (TREE_CODE (field) == FIELD_DECL);
  decl = se->expr;
  tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);

  se->expr = tmp;

  if (c->ts.type == BT_CHARACTER)
    {
      tmp = c->ts.cl->backend_decl;
      /* Components must always be constant length.  */
      gcc_assert (tmp && INTEGER_CST_P (tmp));
      se->string_length = tmp;
    }

  if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
    se->expr = gfc_build_indirect_ref (se->expr);
}


/* Return the contents of a variable. Also handles reference/pointer
   variables (all Fortran pointer references are implicit).  */

static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
  gfc_ref *ref;
  gfc_symbol *sym;

  sym = expr->symtree->n.sym;
  if (se->ss != NULL)
    {
      /* Check that something hasn't gone horribly wrong.  */
      gcc_assert (se->ss != gfc_ss_terminator);
      gcc_assert (se->ss->expr == expr);

      /* A scalarized term.  We already know the descriptor.  */
      se->expr = se->ss->data.info.descriptor;
      se->string_length = se->ss->string_length;
      for (ref = se->ss->data.info.ref; ref; ref = ref->next)
	if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
	  break;
    }
  else
    {
      tree se_expr = NULL_TREE;

      se->expr = gfc_get_symbol_decl (sym);

      /* Special case for assigning the return value of a function.
	 Self recursive functions must have an explicit return value.  */
      if (se->expr == current_function_decl && sym->attr.function
	  && (sym->result == sym))
	se_expr = gfc_get_fake_result_decl (sym);

      /* Similarly for alternate entry points.  */
      else if (sym->attr.function && sym->attr.entry
	       && (sym->result == sym)
	       && sym->ns->proc_name->backend_decl == current_function_decl)
	{
	  gfc_entry_list *el = NULL;

	  for (el = sym->ns->entries; el; el = el->next)
	    if (sym == el->sym)
	      {
		se_expr = gfc_get_fake_result_decl (sym);
		break;
	      }
	}

      else if (sym->attr.result
	       && sym->ns->proc_name->backend_decl == current_function_decl
	       && sym->ns->proc_name->attr.entry_master
	       && !gfc_return_by_reference (sym->ns->proc_name))
	se_expr = gfc_get_fake_result_decl (sym);

      if (se_expr)
	se->expr = se_expr;

      /* Procedure actual arguments.  */
      else if (sym->attr.flavor == FL_PROCEDURE
	       && se->expr != current_function_decl)
	{
	  gcc_assert (se->want_pointer);
	  if (!sym->attr.dummy)
	    {
	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
	      se->expr = gfc_build_addr_expr (NULL, se->expr);
	    }
	  return;
	}


      /* Dereference the expression, where needed. Since characters
	 are entirely different from other types, they are treated 
	 separately.  */
      if (sym->ts.type == BT_CHARACTER)
	{
          /* Dereference character pointer dummy arguments
	     or results.  */
	  if ((sym->attr.pointer || sym->attr.allocatable)
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result))
	    se->expr = gfc_build_indirect_ref (se->expr);
	}
      else
	{
          /* Dereference non-character scalar dummy arguments.  */
	  if (sym->attr.dummy && !sym->attr.dimension)
	    se->expr = gfc_build_indirect_ref (se->expr);

          /* Dereference scalar hidden result.  */
	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
	      && (sym->attr.function || sym->attr.result)
	      && !sym->attr.dimension && !sym->attr.pointer)
	    se->expr = gfc_build_indirect_ref (se->expr);

          /* Dereference non-character pointer variables. 
	     These must be dummies, results, or scalars.  */
	  if ((sym->attr.pointer || sym->attr.allocatable)
	      && (sym->attr.dummy
		  || sym->attr.function
		  || sym->attr.result
		  || !sym->attr.dimension))
	    se->expr = gfc_build_indirect_ref (se->expr);
	}

      ref = expr->ref;
    }

  /* For character variables, also get the length.  */
  if (sym->ts.type == BT_CHARACTER)
    {
      /* If the character length of an entry isn't set, get the length from
         the master function instead.  */
      if (sym->attr.entry && !sym->ts.cl->backend_decl)
        se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
      else
        se->string_length = sym->ts.cl->backend_decl;
      gcc_assert (se->string_length);
    }

  while (ref)
    {
      switch (ref->type)
	{
	case REF_ARRAY:
	  /* Return the descriptor if that's what we want and this is an array
	     section reference.  */
	  if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
	    return;
/* TODO: Pointers to single elements of array sections, eg elemental subs.  */
	  /* Return the descriptor for array pointers and allocations.  */
	  if (se->want_pointer
	      && ref->next == NULL && (se->descriptor_only))
	    return;

	  gfc_conv_array_ref (se, &ref->u.ar);
	  /* Return a pointer to an element.  */
	  break;

	case REF_COMPONENT:
	  gfc_conv_component_ref (se, ref);
	  break;

	case REF_SUBSTRING:
	  gfc_conv_substring (se, ref, expr->ts.kind);
	  break;

	default:
	  gcc_unreachable ();
	  break;
	}
      ref = ref->next;
    }
  /* Pointer assignment, allocation or pass by reference.  Arrays are handled
     separately.  */
  if (se->want_pointer)
    {
      if (expr->ts.type == BT_CHARACTER)
	gfc_conv_string_parameter (se);
      else 
	se->expr = gfc_build_addr_expr (NULL, se->expr);
    }
}


/* Unary ops are easy... Or they would be if ! was a valid op.  */

static void
gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
{
  gfc_se operand;
  tree type;

  gcc_assert (expr->ts.type != BT_CHARACTER);
  /* Initialize the operand.  */