check.c

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

try
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
{
  if (numeric_check (x, 0) == FAILURE)
    return FAILURE;

  if (y != NULL)
    {
      if (numeric_check (y, 1) == FAILURE)
	return FAILURE;

      if (x->ts.type == BT_COMPLEX)
	{
	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
		     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
		     gfc_current_intrinsic, &y->where);
	  return FAILURE;
	}
    }

  if (kind_check (kind, 2, BT_COMPLEX) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_complex (gfc_expr * x, gfc_expr * y)
{
  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
    {
      gfc_error (
	"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
	gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
      return FAILURE;
    }
  if (scalar_check (x, 0) == FAILURE)
    return FAILURE;

  if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
    {
      gfc_error (
	"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
	gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
      return FAILURE;
    }
  if (scalar_check (y, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
{
  if (logical_array_check (mask, 0) == FAILURE)
    return FAILURE;
  if (dim_check (dim, 1, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim)
{
  if (array_check (array, 0) == FAILURE)
    return FAILURE;

  if (array->rank == 1)
    {
      if (scalar_check (shift, 1) == FAILURE)
	return FAILURE;
    }
  else
    {
      /* TODO: more requirements on shift parameter.  */
    }

  if (dim_check (dim, 2, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ctime (gfc_expr * time)
{
  if (scalar_check (time, 0) == FAILURE)
    return FAILURE;

  if (type_check (time, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_dcmplx (gfc_expr * x, gfc_expr * y)
{
  if (numeric_check (x, 0) == FAILURE)
    return FAILURE;

  if (y != NULL)
    {
      if (numeric_check (y, 1) == FAILURE)
	return FAILURE;

      if (x->ts.type == BT_COMPLEX)
	{
	  gfc_error ("'%s' argument of '%s' intrinsic at %L must not be "
		     "present if 'x' is COMPLEX", gfc_current_intrinsic_arg[1],
		     gfc_current_intrinsic, &y->where);
	  return FAILURE;
	}
    }

  return SUCCESS;
}


try
gfc_check_dble (gfc_expr * x)
{
  if (numeric_check (x, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_digits (gfc_expr * x)
{
  if (int_or_real_check (x, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
{
  switch (vector_a->ts.type)
    {
    case BT_LOGICAL:
      if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE)
	return FAILURE;
      break;

    case BT_INTEGER:
    case BT_REAL:
    case BT_COMPLEX:
      if (numeric_check (vector_b, 1) == FAILURE)
	return FAILURE;
      break;

    default:
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
		 "or LOGICAL", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &vector_a->where);
      return FAILURE;
    }

  if (rank_check (vector_a, 0, 1) == FAILURE)
    return FAILURE;

  if (rank_check (vector_b, 1, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary,
		   gfc_expr * dim)
{
  if (array_check (array, 0) == FAILURE)
    return FAILURE;

  if (type_check (shift, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (array->rank == 1)
    {
      if (scalar_check (shift, 2) == FAILURE)
	return FAILURE;
    }
  else
    {
      /* TODO: more weird restrictions on shift.  */
    }

  if (boundary != NULL)
    {
      if (same_type_check (array, 0, boundary, 2) == FAILURE)
	return FAILURE;

      /* TODO: more restrictions on boundary.  */
    }

  if (dim_check (dim, 1, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* A single complex argument.  */

try
gfc_check_fn_c (gfc_expr * a)
{
  if (type_check (a, 0, BT_COMPLEX) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* A single real argument.  */

try
gfc_check_fn_r (gfc_expr * a)
{
  if (type_check (a, 0, BT_REAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* A single real or complex argument.  */

try
gfc_check_fn_rc (gfc_expr * a)
{
  if (real_or_complex_check (a, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_fnum (gfc_expr * unit)
{
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (scalar_check (unit, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* This is used for the g77 one-argument Bessel functions, and the
   error function.  */

try
gfc_check_g77_math1 (gfc_expr * x)
{
  if (scalar_check (x, 0) == FAILURE)
    return FAILURE;

  if (type_check (x, 0, BT_REAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_huge (gfc_expr * x)
{
  if (int_or_real_check (x, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* Check that the single argument is an integer.  */

try
gfc_check_i (gfc_expr * i)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_iand (gfc_expr * i, gfc_expr * j)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (j, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (i->ts.kind != j->ts.kind)
    {
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
                          &i->where) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_ibclr (gfc_expr * i, gfc_expr * pos)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (len, 2, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ibset (gfc_expr * i, gfc_expr * pos)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ichar_iachar (gfc_expr * c)
{
  int i;

  if (type_check (c, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING)
    {
      gfc_expr *start;
      gfc_expr *end;
      gfc_ref *ref;

      /* Substring references don't have the charlength set.  */
      ref = c->ref;
      while (ref && ref->type != REF_SUBSTRING)
	ref = ref->next;

      gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);

      if (!ref)
	{
          /* Check that the argument is length one.  Non-constant lengths
	     can't be checked here, so assume thay are ok.  */
	  if (c->ts.cl && c->ts.cl->length)
	    {
	      /* If we already have a length for this expression then use it.  */
	      if (c->ts.cl->length->expr_type != EXPR_CONSTANT)
		return SUCCESS;
	      i = mpz_get_si (c->ts.cl->length->value.integer);
	    }
	  else 
	    return SUCCESS;
	}
      else
	{
	  start = ref->u.ss.start;
	  end = ref->u.ss.end;

	  gcc_assert (start);
	  if (end == NULL || end->expr_type != EXPR_CONSTANT
	      || start->expr_type != EXPR_CONSTANT)
	    return SUCCESS;

	  i = mpz_get_si (end->value.integer) + 1
	      - mpz_get_si (start->value.integer);
	}
    }
  else
    return SUCCESS;

  if (i != 1)
    {
      gfc_error ("Argument of %s at %L must be of length one", 
		 gfc_current_intrinsic, &c->where);
      return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_idnint (gfc_expr * a)
{
  if (double_check (a, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ieor (gfc_expr * i, gfc_expr * j)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (j, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (i->ts.kind != j->ts.kind)
    {
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
                          &i->where) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back)
{
  if (type_check (string, 0, BT_CHARACTER) == FAILURE
      || type_check (substring, 1, BT_CHARACTER) == FAILURE)
    return FAILURE;


  if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE)
    return FAILURE;

  if (string->ts.kind != substring->ts.kind)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same "
		 "kind as '%s'", gfc_current_intrinsic_arg[1],
		 gfc_current_intrinsic, &substring->where,
		 gfc_current_intrinsic_arg[0]);
      return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_int (gfc_expr * x, gfc_expr * kind)
{
  if (numeric_check (x, 0) == FAILURE)
    return FAILURE;

  if (kind != NULL)
    {
      if (type_check (kind, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

      if (scalar_check (kind, 1) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_ior (gfc_expr * i, gfc_expr * j)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (j, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (i->ts.kind != j->ts.kind)
    {
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L",
                          &i->where) == FAILURE)
    return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_ishft (gfc_expr * i, gfc_expr * shift)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE
      || type_check (shift, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE
      || type_check (shift, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
{
  if (type_check (pid, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (sig, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
{
  if (type_check (pid, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (type_check (sig, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (status == NULL)
    return SUCCESS;

  if (type_check (status, 2, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (scalar_check (status, 2) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_kind (gfc_expr * x)
{
  if (x->ts.type == BT_DERIVED)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a "
		 "non-derived type", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &x->where);
      return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
{
  if (array_check (array, 0) == FAILURE)
    return FAILURE;

  if (dim != NULL)
    {
      if (dim_check (dim, 1, 1) == FAILURE)
	return FAILURE;

      if (dim_rank_check (dim, array, 1) == FAILURE)
	return FAILURE;
    }
  return SUCCESS;
}


try
gfc_check_link (gfc_expr * path1, gfc_expr * path2)
{
  if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
    return FAILURE;

  return SUCCESS;