expr.c

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

/* Returns an expression node that is a logical constant.  */

gfc_expr *
gfc_logical_expr (int i, locus * where)
{
  gfc_expr *p;

  p = gfc_get_expr ();

  p->expr_type = EXPR_CONSTANT;
  p->ts.type = BT_LOGICAL;
  p->ts.kind = gfc_default_logical_kind;

  if (where == NULL)
    where = &gfc_current_locus;
  p->where = *where;
  p->value.logical = i;

  return p;
}


/* Return an expression node with an optional argument list attached.
   A variable number of gfc_expr pointers are strung together in an
   argument list with a NULL pointer terminating the list.  */

gfc_expr *
gfc_build_conversion (gfc_expr * e)
{
  gfc_expr *p;

  p = gfc_get_expr ();
  p->expr_type = EXPR_FUNCTION;
  p->symtree = NULL;
  p->value.function.actual = NULL;

  p->value.function.actual = gfc_get_actual_arglist ();
  p->value.function.actual->expr = e;

  return p;
}


/* Given an expression node with some sort of numeric binary
   expression, insert type conversions required to make the operands
   have the same type.

   The exception is that the operands of an exponential don't have to
   have the same type.  If possible, the base is promoted to the type
   of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
   1.0**2 stays as it is.  */

void
gfc_type_convert_binary (gfc_expr * e)
{
  gfc_expr *op1, *op2;

  op1 = e->value.op.op1;
  op2 = e->value.op.op2;

  if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
    {
      gfc_clear_ts (&e->ts);
      return;
    }

  /* Kind conversions of same type.  */
  if (op1->ts.type == op2->ts.type)
    {

      if (op1->ts.kind == op2->ts.kind)
	{
          /* No type conversions.  */
	  e->ts = op1->ts;
	  goto done;
	}

      if (op1->ts.kind > op2->ts.kind)
	gfc_convert_type (op2, &op1->ts, 2);
      else
	gfc_convert_type (op1, &op2->ts, 2);

      e->ts = op1->ts;
      goto done;
    }

  /* Integer combined with real or complex.  */
  if (op2->ts.type == BT_INTEGER)
    {
      e->ts = op1->ts;

      /* Special case for ** operator.  */
      if (e->value.op.operator == INTRINSIC_POWER)
	goto done;

      gfc_convert_type (e->value.op.op2, &e->ts, 2);
      goto done;
    }

  if (op1->ts.type == BT_INTEGER)
    {
      e->ts = op2->ts;
      gfc_convert_type (e->value.op.op1, &e->ts, 2);
      goto done;
    }

  /* Real combined with complex.  */
  e->ts.type = BT_COMPLEX;
  if (op1->ts.kind > op2->ts.kind)
    e->ts.kind = op1->ts.kind;
  else
    e->ts.kind = op2->ts.kind;
  if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
    gfc_convert_type (e->value.op.op1, &e->ts, 2);
  if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
    gfc_convert_type (e->value.op.op2, &e->ts, 2);

done:
  return;
}


/* Function to determine if an expression is constant or not.  This
   function expects that the expression has already been simplified.  */

int
gfc_is_constant_expr (gfc_expr * e)
{
  gfc_constructor *c;
  gfc_actual_arglist *arg;
  int rv;

  if (e == NULL)
    return 1;

  switch (e->expr_type)
    {
    case EXPR_OP:
      rv = (gfc_is_constant_expr (e->value.op.op1)
	    && (e->value.op.op2 == NULL
		|| gfc_is_constant_expr (e->value.op.op2)));

      break;

    case EXPR_VARIABLE:
      rv = 0;
      break;

    case EXPR_FUNCTION:
      /* Call to intrinsic with at least one argument.  */
      rv = 0;
      if (e->value.function.isym && e->value.function.actual)
	{
	  for (arg = e->value.function.actual; arg; arg = arg->next)
	    {
	      if (!gfc_is_constant_expr (arg->expr))
		break;
	    }
	  if (arg == NULL)
	    rv = 1;
	}
      break;

    case EXPR_CONSTANT:
    case EXPR_NULL:
      rv = 1;
      break;

    case EXPR_SUBSTRING:
      rv = (gfc_is_constant_expr (e->ref->u.ss.start)
	    && gfc_is_constant_expr (e->ref->u.ss.end));
      break;

    case EXPR_STRUCTURE:
      rv = 0;
      for (c = e->value.constructor; c; c = c->next)
	if (!gfc_is_constant_expr (c->expr))
	  break;

      if (c == NULL)
	rv = 1;
      break;

    case EXPR_ARRAY:
      rv = gfc_constant_ac (e);
      break;

    default:
      gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
    }

  return rv;
}


/* Try to collapse intrinsic expressions.  */

static try
simplify_intrinsic_op (gfc_expr * p, int type)
{
  gfc_expr *op1, *op2, *result;

  if (p->value.op.operator == INTRINSIC_USER)
    return SUCCESS;

  op1 = p->value.op.op1;
  op2 = p->value.op.op2;

  if (gfc_simplify_expr (op1, type) == FAILURE)
    return FAILURE;
  if (gfc_simplify_expr (op2, type) == FAILURE)
    return FAILURE;

  if (!gfc_is_constant_expr (op1)
      || (op2 != NULL && !gfc_is_constant_expr (op2)))
    return SUCCESS;

  /* Rip p apart */
  p->value.op.op1 = NULL;
  p->value.op.op2 = NULL;

  switch (p->value.op.operator)
    {
    case INTRINSIC_UPLUS:
    case INTRINSIC_PARENTHESES:
      result = gfc_uplus (op1);
      break;

    case INTRINSIC_UMINUS:
      result = gfc_uminus (op1);
      break;

    case INTRINSIC_PLUS:
      result = gfc_add (op1, op2);
      break;

    case INTRINSIC_MINUS:
      result = gfc_subtract (op1, op2);
      break;

    case INTRINSIC_TIMES:
      result = gfc_multiply (op1, op2);
      break;

    case INTRINSIC_DIVIDE:
      result = gfc_divide (op1, op2);
      break;

    case INTRINSIC_POWER:
      result = gfc_power (op1, op2);
      break;

    case INTRINSIC_CONCAT:
      result = gfc_concat (op1, op2);
      break;

    case INTRINSIC_EQ:
      result = gfc_eq (op1, op2);
      break;

    case INTRINSIC_NE:
      result = gfc_ne (op1, op2);
      break;

    case INTRINSIC_GT:
      result = gfc_gt (op1, op2);
      break;

    case INTRINSIC_GE:
      result = gfc_ge (op1, op2);
      break;

    case INTRINSIC_LT:
      result = gfc_lt (op1, op2);
      break;

    case INTRINSIC_LE:
      result = gfc_le (op1, op2);
      break;

    case INTRINSIC_NOT:
      result = gfc_not (op1);
      break;

    case INTRINSIC_AND:
      result = gfc_and (op1, op2);
      break;

    case INTRINSIC_OR:
      result = gfc_or (op1, op2);
      break;

    case INTRINSIC_EQV:
      result = gfc_eqv (op1, op2);
      break;

    case INTRINSIC_NEQV:
      result = gfc_neqv (op1, op2);
      break;

    default:
      gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
    }

  if (result == NULL)
    {
      gfc_free_expr (op1);
      gfc_free_expr (op2);
      return FAILURE;
    }

  gfc_replace_expr (p, result);

  return SUCCESS;
}


/* Subroutine to simplify constructor expressions.  Mutually recursive
   with gfc_simplify_expr().  */

static try
simplify_constructor (gfc_constructor * c, int type)
{

  for (; c; c = c->next)
    {
      if (c->iterator
	  && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
	      || gfc_simplify_expr (c->iterator->end, type) == FAILURE
	      || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
	return FAILURE;

      if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


/* Pull a single array element out of an array constructor.  */

static gfc_constructor *
find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
{
  unsigned long nelemen;
  int i;
  mpz_t delta;
  mpz_t offset;

  mpz_init_set_ui (offset, 0);
  mpz_init (delta);
  for (i = 0; i < ar->dimen; i++)
    {
      if (ar->start[i]->expr_type != EXPR_CONSTANT)
	{
	  cons = NULL;
	  break;
	}
      mpz_sub (delta, ar->start[i]->value.integer,
	       ar->as->lower[i]->value.integer);
      mpz_add (offset, offset, delta);
    }

  if (cons)
    {
      if (mpz_fits_ulong_p (offset))
	{
	  for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
	    {
	      if (cons->iterator)
		{
		  cons = NULL;
		  break;
		}
	      cons = cons->next;
	    }
	}
      else
	cons = NULL;
    }

  mpz_clear (delta);
  mpz_clear (offset);

  return cons;
}


/* Find a component of a structure constructor.  */

static gfc_constructor *
find_component_ref (gfc_constructor * cons, gfc_ref * ref)
{
  gfc_component *comp;
  gfc_component *pick;

  comp = ref->u.c.sym->components;
  pick = ref->u.c.component;
  while (comp != pick)
    {
      comp = comp->next;
      cons = cons->next;
    }

  return cons;
}


/* Replace an expression with the contents of a constructor, removing
   the subobject reference in the process.  */

static void
remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
{
  gfc_expr *e;

  e = cons->expr;
  cons->expr = NULL;
  e->ref = p->ref->next;
  p->ref->next =  NULL;
  gfc_replace_expr (p, e);
}


/* Simplify a subobject reference of a constructor.  This occurs when
   parameter variable values are substituted.  */

static try
simplify_const_ref (gfc_expr * p)
{
  gfc_constructor *cons;

  while (p->ref)
    {
      switch (p->ref->type)
	{
	case REF_ARRAY:
	  switch (p->ref->u.ar.type)
	    {
	    case AR_ELEMENT:
	      cons = find_array_element (p->value.constructor, &p->ref->u.ar);
	      if (!cons)
		return SUCCESS;
	      remove_subobject_ref (p, cons);
	      break;

	    case AR_FULL:
	      if (p->ref->next != NULL)
		{
		  /* TODO: Simplify array subobject references.  */
		  return SUCCESS;
		}
		gfc_free_ref_list (p->ref);
		p->ref = NULL;
	      break;

	    default:
	      /* TODO: Simplify array subsections.  */
	      return SUCCESS;
	    }

	  break;

	case REF_COMPONENT:
	  cons = find_component_ref (p->value.constructor, p->ref);
	  remove_subobject_ref (p, cons);
	  break;

	case REF_SUBSTRING:
	  /* TODO: Constant substrings.  */
	  return SUCCESS;
	}
    }

  return SUCCESS;
}


/* Simplify a chain of references.  */

static try
simplify_ref_chain (gfc_ref * ref, int type)
{
  int n;

  for (; ref; ref = ref->next)
    {
      switch (ref->type)
	{
	case REF_ARRAY:
	  for (n = 0; n < ref->u.ar.dimen; n++)
	    {
	      if (gfc_simplify_expr (ref->u.ar.start[n], type)
		    == FAILURE)
		return FAILURE;
	      if (gfc_simplify_expr (ref->u.ar.end[n], type)
		     == FAILURE)
		return FAILURE;
	      if (gfc_simplify_expr (ref->u.ar.stride[n], type)
		     == FAILURE)
		return FAILURE;
	    }
	  break;

	case REF_SUBSTRING:
	  if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
	    return FAILURE;
	  if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
	    return FAILURE;
	  break;

	default:
	  break;
	}
    }
  return SUCCESS;
}


/* Try to substitute the value of a parameter variable.  */
static try
simplify_parameter_variable (gfc_expr * p, int type)
{
  gfc_expr *e;
  try t;

  e = gfc_copy_expr (p->symtree->n.sym->value);
  /* Do not copy subobject refs for constant.  */
  if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
    e->ref = copy_ref (p->ref);
  t = gfc_simplify_expr (e, type);

  /* Only use the simplification if it eliminated all subobject
     references.  */
  if (t == SUCCESS && ! e->ref)
    gfc_replace_expr (p, e);
  else
    gfc_free_expr (e);

  return t;
}

/* Given an expression, simplify it by collapsing constant
   expressions.  Most simplification takes place when the expression
   tree is being constructed.  If an intrinsic function is simplified
   at some point, we get called again to collapse the result against
   other constants.

   We work by recursively simplifying expression nodes, simplifying
   intrinsic functions where possible, which can lead to further
   constant collapsing.  If an operator has constant operand(s), we
   rip the expression apart, and rebuild it, hoping that it becomes
   something simpler.

   The expression type is defined for:
     0   Basic expression parsing
     1   Simplifying array constructors -- will substitute
         iterator values.
   Returns FAILURE on error, SUCCESS otherwise.