check.c

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

}


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

  if (type_check (path2, 1, BT_CHARACTER) == 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_loc (gfc_expr *expr)
{
  return variable_check (expr, 0);
}


try
gfc_check_symlnk (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;
}


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

  if (type_check (path2, 1, BT_CHARACTER) == 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_logical (gfc_expr * a, gfc_expr * kind)
{
  if (type_check (a, 0, BT_LOGICAL) == FAILURE)
    return FAILURE;
  if (kind_check (kind, 1, BT_LOGICAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* Min/max family.  */

static try
min_max_args (gfc_actual_arglist * arg)
{
  if (arg == NULL || arg->next == NULL)
    {
      gfc_error ("Intrinsic '%s' at %L must have at least two arguments",
		 gfc_current_intrinsic, gfc_current_intrinsic_where);
      return FAILURE;
    }

  return SUCCESS;
}


static try
check_rest (bt type, int kind, gfc_actual_arglist * arg)
{
  gfc_expr *x;
  int n;

  if (min_max_args (arg) == FAILURE)
    return FAILURE;

  n = 1;

  for (; arg; arg = arg->next, n++)
    {
      x = arg->expr;
      if (x->ts.type != type || x->ts.kind != kind)
	{
          if (x->ts.type == type)
            {
	      if (gfc_notify_std (GFC_STD_GNU,
		    "Extension: Different type kinds at %L", &x->where)
		  == FAILURE)
		return FAILURE;
            }
          else
            {
              gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)",
                         n, gfc_current_intrinsic, &x->where,
                         gfc_basic_typename (type), kind);
              return FAILURE;
            }
	}
    }

  return SUCCESS;
}


try
gfc_check_min_max (gfc_actual_arglist * arg)
{
  gfc_expr *x;

  if (min_max_args (arg) == FAILURE)
    return FAILURE;

  x = arg->expr;

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

  return check_rest (x->ts.type, x->ts.kind, arg);
}


try
gfc_check_min_max_integer (gfc_actual_arglist * arg)
{
  return check_rest (BT_INTEGER, gfc_default_integer_kind, arg);
}


try
gfc_check_min_max_real (gfc_actual_arglist * arg)
{
  return check_rest (BT_REAL, gfc_default_real_kind, arg);
}


try
gfc_check_min_max_double (gfc_actual_arglist * arg)
{
  return check_rest (BT_REAL, gfc_default_double_kind, arg);
}

/* End of min/max family.  */

try
gfc_check_malloc (gfc_expr * size)
{
  if (type_check (size, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
{
  if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts))
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
		 "or LOGICAL", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &matrix_a->where);
      return FAILURE;
    }

  if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts))
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be numeric "
		 "or LOGICAL", gfc_current_intrinsic_arg[1],
		 gfc_current_intrinsic, &matrix_b->where);
      return FAILURE;
    }

  switch (matrix_a->rank)
    {
    case 1:
      if (rank_check (matrix_b, 1, 2) == FAILURE)
	return FAILURE;
      break;

    case 2:
      if (matrix_b->rank == 2)
	break;
      if (rank_check (matrix_b, 1, 1) == FAILURE)
	return FAILURE;
      break;

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

  return SUCCESS;
}


/* Whoever came up with this interface was probably on something.
   The possibilities for the occupation of the second and third
   parameters are:

         Arg #2     Arg #3
         NULL       NULL
         DIM        NULL
         MASK       NULL
         NULL       MASK             minloc(array, mask=m)
         DIM        MASK

   I.e. in the case of minloc(array,mask), mask will be in the second
   position of the argument list and we'll have to fix that up.  */

try
gfc_check_minloc_maxloc (gfc_actual_arglist * ap)
{
  gfc_expr *a, *m, *d;

  a = ap->expr;
  if (int_or_real_check (a, 0) == FAILURE
      || array_check (a, 0) == FAILURE)
    return FAILURE;

  d = ap->next->expr;
  m = ap->next->next->expr;

  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
      && ap->next->name == NULL)
    {
      m = d;
      d = NULL;

      ap->next->expr = NULL;
      ap->next->next->expr = m;
    }

  if (d != NULL
      && (scalar_check (d, 1) == FAILURE
      || type_check (d, 1, BT_INTEGER) == FAILURE))
    return FAILURE;

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

  if (m != NULL)
    {
      char buffer[80];
      snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
	       gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
	       gfc_current_intrinsic);
      if (gfc_check_conformance (buffer, a, m) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


/* Similar to minloc/maxloc, the argument list might need to be
   reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics.  The
   difference is that MINLOC/MAXLOC take an additional KIND argument.
   The possibilities are:

         Arg #2     Arg #3
         NULL       NULL
         DIM        NULL
         MASK       NULL
         NULL       MASK             minval(array, mask=m)
         DIM        MASK

   I.e. in the case of minval(array,mask), mask will be in the second
   position of the argument list and we'll have to fix that up.  */

static try
check_reduction (gfc_actual_arglist * ap)
{
  gfc_expr *a, *m, *d;

  a = ap->expr;
  d = ap->next->expr;
  m = ap->next->next->expr;

  if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL
      && ap->next->name == NULL)
    {
      m = d;
      d = NULL;

      ap->next->expr = NULL;
      ap->next->next->expr = m;
    }

  if (d != NULL
      && (scalar_check (d, 1) == FAILURE
      || type_check (d, 1, BT_INTEGER) == FAILURE))
    return FAILURE;

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

  if (m != NULL)
    {
      char buffer[80];
      snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic %s",
	       gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
	       gfc_current_intrinsic);
      if (gfc_check_conformance (buffer, a, m) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_minval_maxval (gfc_actual_arglist * ap)
{
  if (int_or_real_check (ap->expr, 0) == FAILURE
      || array_check (ap->expr, 0) == FAILURE)
    return FAILURE;

  return check_reduction (ap);
}


try
gfc_check_product_sum (gfc_actual_arglist * ap)
{
  if (numeric_check (ap->expr, 0) == FAILURE
      || array_check (ap->expr, 0) == FAILURE)
    return FAILURE;

  return check_reduction (ap);
}


try
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
{
  if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
    return FAILURE;

  if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_nearest (gfc_expr * x, gfc_expr * s)
{
  if (type_check (x, 0, BT_REAL) == FAILURE)
    return FAILURE;

  if (type_check (s, 1, BT_REAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_null (gfc_expr * mold)
{
  symbol_attribute attr;

  if (mold == NULL)
    return SUCCESS;

  if (variable_check (mold, 0) == FAILURE)
    return FAILURE;

  attr = gfc_variable_attr (mold, NULL);

  if (!attr.pointer)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
		 gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &mold->where);
      return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
{
  if (array_check (array, 0) == FAILURE)
    return FAILURE;

  if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
    return FAILURE;

  if (mask->rank != 0 && mask->rank != array->rank)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
		 "with '%s' argument", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &array->where,
		 gfc_current_intrinsic_arg[1]);
      return FAILURE;
    }

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

      if (rank_check (vector, 2, 1) == FAILURE)
	return FAILURE;

      /* TODO: More constraints here.  */
    }

  return SUCCESS;
}


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

  return SUCCESS;
}


try
gfc_check_present (gfc_expr * a)
{
  gfc_symbol *sym;

  if (variable_check (a, 0) == FAILURE)
    return FAILURE;

  sym = a->symtree->n.sym;
  if (!sym->attr.dummy)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a "
		 "dummy variable", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &a->where);
      return FAILURE;
    }

  if (!sym->attr.optional)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be of "
		 "an OPTIONAL dummy variable", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &a->where);
      return FAILURE;
    }

  return SUCCESS;
}


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

  return SUCCESS;
}


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

  return SUCCESS;
}


/* real, float, sngl.  */
try
gfc_check_real (gfc_expr * a, gfc_expr * kind)
{
  if (numeric_check (a, 0) == FAILURE)
    return FAILURE;

  if (kind_check (kind, 1, BT_REAL) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_rename (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;
}


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

  if (type_check (path2, 1, BT_CHARACTER) == 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_repeat (gfc_expr * x, gfc_expr * y)
{
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

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

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

  if (scalar_check (y, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_reshape (gfc_expr * source, gfc_expr * shape,
		   gfc_expr * pad, gfc_expr * order)
{
  mpz_t size;
  int m;

  if (array_check (source, 0) == FAILURE)
    return FAILURE;

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

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

  if (gfc_array_size (shape, &size) != SUCCESS)
    {
      gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an "
		 "array of constant size", &shape->where);
      return FAILURE;
    }

  m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS);
  mpz_clear (size);

  if (m > 0)
    {
      gfc_error ("'shape' argument of 'reshape' intrinsic at %L has more "
		 "than %d elements", &shape->where, GFC_MAX_DIMENSIONS);
      return FAILURE;
    }

  if (pad != NULL)
    {
      if (same_type_check (source, 0, pad, 2) == FAILURE)
	return FAILURE;
      if (array_check (pad, 2) == FAILURE)
	return FAILURE;
    }