expr.c

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

  if (e == NULL)
    return SUCCESS;

  switch (e->expr_type)
    {
    case EXPR_OP:
      t = check_intrinsic_op (e, check_restricted);
      if (t == SUCCESS)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_FUNCTION:
      t = e->value.function.esym ?
	external_spec_function (e) : restricted_intrinsic (e);

      break;

    case EXPR_VARIABLE:
      sym = e->symtree->n.sym;
      t = FAILURE;

      if (sym->attr.optional)
	{
	  gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
		     sym->name, &e->where);
	  break;
	}

      if (sym->attr.intent == INTENT_OUT)
	{
	  gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
		     sym->name, &e->where);
	  break;
	}

      /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
	 in resolve.c(resolve_formal_arglist).  This is done so that host associated
	 dummy array indices are accepted (PR23446).  */
      if (sym->attr.in_common
	  || sym->attr.use_assoc
	  || sym->attr.dummy
	  || sym->ns != gfc_current_ns
	  || (sym->ns->proc_name != NULL
	      && sym->ns->proc_name->attr.flavor == FL_MODULE)
	  || gfc_is_formal_arg ())
	{
	  t = SUCCESS;
	  break;
	}

      gfc_error ("Variable '%s' cannot appear in the expression at %L",
		 sym->name, &e->where);

      break;

    case EXPR_NULL:
    case EXPR_CONSTANT:
      t = SUCCESS;
      break;

    case EXPR_SUBSTRING:
      t = gfc_specification_expr (e->ref->u.ss.start);
      if (t == FAILURE)
	break;

      t = gfc_specification_expr (e->ref->u.ss.end);
      if (t == SUCCESS)
	t = gfc_simplify_expr (e, 0);

      break;

    case EXPR_STRUCTURE:
      t = gfc_check_constructor (e, check_restricted);
      break;

    case EXPR_ARRAY:
      t = gfc_check_constructor (e, check_restricted);
      break;

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

  return t;
}


/* Check to see that an expression is a specification expression.  If
   we return FAILURE, an error has been generated.  */

try
gfc_specification_expr (gfc_expr * e)
{
  if (e == NULL)
    return SUCCESS;

  if (e->ts.type != BT_INTEGER)
    {
      gfc_error ("Expression at %L must be of INTEGER type", &e->where);
      return FAILURE;
    }

  if (e->rank != 0)
    {
      gfc_error ("Expression at %L must be scalar", &e->where);
      return FAILURE;
    }

  if (gfc_simplify_expr (e, 0) == FAILURE)
    return FAILURE;

  return check_restricted (e);
}


/************** Expression conformance checks.  *************/

/* Given two expressions, make sure that the arrays are conformable.  */

try
gfc_check_conformance (const char *optype_msgid,
		       gfc_expr * op1, gfc_expr * op2)
{
  int op1_flag, op2_flag, d;
  mpz_t op1_size, op2_size;
  try t;

  if (op1->rank == 0 || op2->rank == 0)
    return SUCCESS;

  if (op1->rank != op2->rank)
    {
      gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
		 &op1->where);
      return FAILURE;
    }

  t = SUCCESS;

  for (d = 0; d < op1->rank; d++)
    {
      op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
      op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;

      if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
	{
	  gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
		     _(optype_msgid), &op1->where, d + 1,
		     (int) mpz_get_si (op1_size),
		     (int) mpz_get_si (op2_size));

	  t = FAILURE;
	}

      if (op1_flag)
	mpz_clear (op1_size);
      if (op2_flag)
	mpz_clear (op2_size);

      if (t == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


/* Given an assignable expression and an arbitrary expression, make
   sure that the assignment can take place.  */

try
gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
{
  gfc_symbol *sym;

  sym = lvalue->symtree->n.sym;

  if (sym->attr.intent == INTENT_IN)
    {
      gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
		 sym->name, &lvalue->where);
      return FAILURE;
    }

  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
    {
      gfc_error ("'%s' in the assignment at %L cannot be an l-value "
		 "since it is a procedure", sym->name, &lvalue->where);
      return FAILURE;
    }


  if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
    {
      gfc_error ("Incompatible ranks %d and %d in assignment at %L",
		 lvalue->rank, rvalue->rank, &lvalue->where);
      return FAILURE;
    }

  if (lvalue->ts.type == BT_UNKNOWN)
    {
      gfc_error ("Variable type is UNKNOWN in assignment at %L",
		 &lvalue->where);
      return FAILURE;
    }

   if (rvalue->expr_type == EXPR_NULL)
     {
       gfc_error ("NULL appears on right-hand side in assignment at %L",
		  &rvalue->where);
       return FAILURE;
     }

   if (sym->attr.cray_pointee
       && lvalue->ref != NULL
       && lvalue->ref->u.ar.type != AR_ELEMENT
       && lvalue->ref->u.ar.as->cp_was_assumed)
     {
       gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
		  " is illegal.", &lvalue->where);
       return FAILURE;
     }

  /* This is possibly a typo: x = f() instead of x => f()  */
  if (gfc_option.warn_surprising 
      && rvalue->expr_type == EXPR_FUNCTION
      && rvalue->symtree->n.sym->attr.pointer)
    gfc_warning ("POINTER valued function appears on right-hand side of "
		 "assignment at %L", &rvalue->where);

  /* Check size of array assignments.  */
  if (lvalue->rank != 0 && rvalue->rank != 0
      && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
    return FAILURE;

  if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
    return SUCCESS;

  if (!conform)
    {
      /* Numeric can be converted to any other numeric. And Hollerith can be
	 converted to any other type.  */
      if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
	  || rvalue->ts.type == BT_HOLLERITH)
	return SUCCESS;

      if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
	return SUCCESS;

      gfc_error ("Incompatible types in assignment at %L, %s to %s",
		 &rvalue->where, gfc_typename (&rvalue->ts),
		 gfc_typename (&lvalue->ts));

      return FAILURE;
    }

  return gfc_convert_type (rvalue, &lvalue->ts, 1);
}


/* Check that a pointer assignment is OK.  We first check lvalue, and
   we only check rvalue if it's not an assignment to NULL() or a
   NULLIFY statement.  */

try
gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
{
  symbol_attribute attr;
  int is_pure;

  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
    {
      gfc_error ("Pointer assignment target is not a POINTER at %L",
		 &lvalue->where);
      return FAILURE;
    }

  if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
	&& lvalue->symtree->n.sym->attr.use_assoc)
    {
      gfc_error ("'%s' in the pointer assignment at %L cannot be an "
		 "l-value since it is a procedure",
		 lvalue->symtree->n.sym->name, &lvalue->where);
      return FAILURE;
    }

  attr = gfc_variable_attr (lvalue, NULL);
  if (!attr.pointer)
    {
      gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
      return FAILURE;
    }

  is_pure = gfc_pure (NULL);

  if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
    {
      gfc_error ("Bad pointer object in PURE procedure at %L",
		 &lvalue->where);
      return FAILURE;
    }

  /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
     kind, etc for lvalue and rvalue must match, and rvalue must be a
     pure variable if we're in a pure function.  */
  if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
    return SUCCESS;

  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
    {
      gfc_error ("Different types in pointer assignment at %L",
		 &lvalue->where);
      return FAILURE;
    }

  if (lvalue->ts.kind != rvalue->ts.kind)
    {
      gfc_error ("Different kind type parameters in pointer "
		 "assignment at %L", &lvalue->where);
      return FAILURE;
    }

  if (lvalue->rank != rvalue->rank)
    {
      gfc_error ("Different ranks in pointer assignment at %L",
		  &lvalue->where);
      return FAILURE;
    }

  /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
  if (rvalue->expr_type == EXPR_NULL)
    return SUCCESS;

  if (lvalue->ts.type == BT_CHARACTER
	&& lvalue->ts.cl->length && rvalue->ts.cl->length
	&& abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
				      rvalue->ts.cl->length)) == 1)
    {
      gfc_error ("Different character lengths in pointer "
		 "assignment at %L", &lvalue->where);
      return FAILURE;
    }

  attr = gfc_expr_attr (rvalue);
  if (!attr.target && !attr.pointer)
    {
      gfc_error ("Pointer assignment target is neither TARGET "
		 "nor POINTER at %L", &rvalue->where);
      return FAILURE;
    }

  if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
    {
      gfc_error ("Bad target in pointer assignment in PURE "
		 "procedure at %L", &rvalue->where);
    }

  if (gfc_has_vector_index (rvalue))
    {
      gfc_error ("Pointer assignment with vector subscript "
		 "on rhs at %L", &rvalue->where);
      return FAILURE;
    }

  if (rvalue->symtree->n.sym
	&& rvalue->symtree->n.sym->as
	&& rvalue->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
    {
      gfc_ref * ref;
      int dim = 0;
      int last = 0;
      for (ref = rvalue->ref; ref; ref = ref->next)
	if (ref->type == REF_ARRAY)
	  for (dim = 0;dim < ref->u.ar.as->rank; dim++)
	    last = ref->u.ar.end[dim] == NULL;
      if (last)
	{
	  gfc_error ("The upper bound in the last dimension of the "
		     "assumed_size array on the rhs of the pointer "
		     "assignment at %L must be set", &rvalue->where);
	  return FAILURE;
	}
    }

  return SUCCESS;
}


/* Relative of gfc_check_assign() except that the lvalue is a single
   symbol.  Used for initialization assignments.  */

try
gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
{
  gfc_expr lvalue;
  try r;

  memset (&lvalue, '\0', sizeof (gfc_expr));

  lvalue.expr_type = EXPR_VARIABLE;
  lvalue.ts = sym->ts;
  if (sym->as)
    lvalue.rank = sym->as->rank;
  lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
  lvalue.symtree->n.sym = sym;
  lvalue.where = sym->declared_at;

  if (sym->attr.pointer)
    r = gfc_check_pointer_assign (&lvalue, rvalue);
  else
    r = gfc_check_assign (&lvalue, rvalue, 1);

  gfc_free (lvalue.symtree);

  return r;
}


/* Get an expression for a default initializer.  */

gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
  gfc_constructor *tail;
  gfc_expr *init;
  gfc_component *c;

  init = NULL;

  /* See if we have a default initializer.  */
  for (c = ts->derived->components; c; c = c->next)
    {
      if (c->initializer && init == NULL)
        init = gfc_get_expr ();
    }

  if (init == NULL)
    return NULL;

  /* Build the constructor.  */
  init->expr_type = EXPR_STRUCTURE;
  init->ts = *ts;
  init->where = ts->derived->declared_at;
  tail = NULL;
  for (c = ts->derived->components; c; c = c->next)
    {
      if (tail == NULL)
        init->value.constructor = tail = gfc_get_constructor ();
      else
        {
          tail->next = gfc_get_constructor ();
          tail = tail->next;
        }

      if (c->initializer)
        tail->expr = gfc_copy_expr (c->initializer);
    }
  return init;
}


/* Given a symbol, create an expression node with that symbol as a
   variable. If the symbol is array valued, setup a reference of the
   whole array.  */

gfc_expr *
gfc_get_variable_expr (gfc_symtree * var)
{
  gfc_expr *e;

  e = gfc_get_expr ();
  e->expr_type = EXPR_VARIABLE;
  e->symtree = var;
  e->ts = var->n.sym->ts;

  if (var->n.sym->as != NULL)
    {
      e->rank = var->n.sym->as->rank;
      e->ref = gfc_get_ref ();
      e->ref->type = REF_ARRAY;
      e->ref->u.ar.type = AR_FULL;
    }

  return e;
}


/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */

void
gfc_expr_set_symbols_referenced (gfc_expr * expr)
{
  gfc_actual_arglist *arg;
  gfc_constructor *c;
  gfc_ref *ref;
  int i;

  if (!expr) return;

  switch (expr->expr_type)
    {
    case EXPR_OP:
      gfc_expr_set_symbols_referenced (expr->value.op.op1);
      gfc_expr_set_symbols_referenced (expr->value.op.op2);
      break;

    case EXPR_FUNCTION:
      for (arg = expr->value.function.actual; arg; arg = arg->next)
        gfc_expr_set_symbols_referenced (arg->expr);
      break;

    case EXPR_VARIABLE:
      gfc_set_sym_referenced (expr->symtree->n.sym);
      break;

    case EXPR_CONSTANT:
    case EXPR_NULL:
    case EXPR_SUBSTRING:
      break;

    case EXPR_STRUCTURE:
    case EXPR_ARRAY:
      for (c = expr->value.constructor; c; c = c->next)
        gfc_expr_set_symbols_referenced (c->expr);
      break;

    default:
      gcc_unreachable ();
      break;
    }

    for (ref = expr->ref; ref; ref = ref->next)
      switch (ref->type)
        {
        case REF_ARRAY:
          for (i = 0; i < ref->u.ar.dimen; i++)
            {
              gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
              gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
              gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
            }
          break;
           
        case REF_COMPONENT:
          break;
           
        case REF_SUBSTRING:
          gfc_expr_set_symbols_referenced (ref->u.ss.start);
          gfc_expr_set_symbols_referenced (ref->u.ss.end);
          break;
           
        default:
          gcc_unreachable ();
          break;
        }
}