check.c

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

  if (order != NULL && array_check (order, 3) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


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

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

  return SUCCESS;
}


try
gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

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

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

  if (same_type_check (x, 0, y, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_secnds (gfc_expr * r)
{

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

  if (kind_value_check (r, 0, 4) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_selected_int_kind (gfc_expr * r)
{

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

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

  return SUCCESS;
}


try
gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r)
{
  if (p == NULL && r == NULL)
    {
      gfc_error ("Missing arguments to %s intrinsic at %L",
		 gfc_current_intrinsic, gfc_current_intrinsic_where);

      return FAILURE;
    }

  if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


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

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

  return SUCCESS;
}


try
gfc_check_shape (gfc_expr * source)
{
  gfc_array_ref *ar;

  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
    return SUCCESS;

  ar = gfc_find_array_ref (source);

  if (ar->as && ar->as->type == AS_ASSUMED_SIZE)
    {
      gfc_error ("'source' argument of 'shape' intrinsic at %L must not be "
		 "an assumed size array", &source->where);
      return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_sign (gfc_expr * a, gfc_expr * b)
{
  if (int_or_real_check (a, 0) == FAILURE)
    return FAILURE;

  if (same_type_check (a, 0, b, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


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

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

      if (kind_value_check (dim, 1, gfc_default_integer_kind) == FAILURE)
	return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_sleep_sub (gfc_expr * seconds)
{
  if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
{
  if (source->rank >= GFC_MAX_DIMENSIONS)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must be less "
		 "than rank %d", gfc_current_intrinsic_arg[0],
		 gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS);

      return FAILURE;
    }

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

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

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

  return SUCCESS;
}


/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
   functions).  */
try
gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
{
  if (type_check (unit, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

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

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

  if (status == NULL)
    return SUCCESS;

  if (type_check (status, 2, BT_INTEGER) == FAILURE
      || kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
      || scalar_check (status, 2) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
{
  return gfc_check_fgetputc_sub (unit, c, NULL);
}


try
gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
{
  if (type_check (c, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (status == NULL)
    return SUCCESS;

  if (type_check (status, 1, BT_INTEGER) == FAILURE
      || kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
      || scalar_check (status, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_fgetput (gfc_expr * c)
{
  return gfc_check_fgetput_sub (c, NULL);
}


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

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

  if (type_check (array, 1, BT_INTEGER) == FAILURE
      || kind_value_check (unit, 0, gfc_default_integer_kind) == FAILURE)
    return FAILURE;

  if (array_check (array, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


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

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

  if (type_check (array, 1, BT_INTEGER) == FAILURE
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
    return FAILURE;

  if (array_check (array, 1) == FAILURE)
    return FAILURE;

  if (status == NULL)
    return SUCCESS;

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

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

  return SUCCESS;
}


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

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

  return SUCCESS;
}


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

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

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

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

  return SUCCESS;
}


try
gfc_check_stat (gfc_expr * name, gfc_expr * array)
{
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (type_check (array, 1, BT_INTEGER) == FAILURE
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
    return FAILURE;

  if (array_check (array, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_stat_sub (gfc_expr * name, gfc_expr * array, gfc_expr * status)
{
  if (type_check (name, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (type_check (array, 1, BT_INTEGER) == FAILURE
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
    return FAILURE;

  if (array_check (array, 1) == FAILURE)
    return FAILURE;

  if (status == NULL)
    return SUCCESS;

  if (type_check (status, 2, BT_INTEGER) == FAILURE
      || kind_value_check (array, 1, gfc_default_integer_kind) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED,
		    gfc_expr * mold ATTRIBUTE_UNUSED,
		    gfc_expr * size)
{
  if (size != NULL)
    {
      if (type_check (size, 2, BT_INTEGER) == FAILURE)
	return FAILURE;

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

      if (nonoptional_check (size, 2) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_transpose (gfc_expr * matrix)
{
  if (rank_check (matrix, 0, 2) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_ubound (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, 0) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field)
{
  if (rank_check (vector, 0, 1) == FAILURE)
    return FAILURE;

  if (array_check (mask, 1) == FAILURE)
    return FAILURE;

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

  if (same_type_check (vector, 0, field, 2) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z)
{
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  if (same_type_check (x, 0, y, 1) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_trim (gfc_expr * x)
{
  if (type_check (x, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

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

   return SUCCESS;
}


try
gfc_check_ttynam (gfc_expr * unit)
{
  if (scalar_check (unit, 0) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


/* Common check function for the half a dozen intrinsics that have a
   single real argument.  */

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

  return SUCCESS;
}


/************* Check functions for intrinsic subroutines *************/

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

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

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

  return SUCCESS;
}


try
gfc_check_date_and_time (gfc_expr * date, gfc_expr * time,
			 gfc_expr * zone, gfc_expr * values)
{
  if (date != NULL)
    {
      if (type_check (date, 0, BT_CHARACTER) == FAILURE)
	return FAILURE;
      if (scalar_check (date, 0) == FAILURE)
	return FAILURE;
      if (variable_check (date, 0) == FAILURE)
	return FAILURE;
    }

  if (time != NULL)
    {
      if (type_check (time, 1, BT_CHARACTER) == FAILURE)
	return FAILURE;
      if (scalar_check (time, 1) == FAILURE)
	return FAILURE;
      if (variable_check (time, 1) == FAILURE)
	return FAILURE;
    }

  if (zone != NULL)
    {
      if (type_check (zone, 2, BT_CHARACTER) == FAILURE)
	return FAILURE;
      if (scalar_check (zone, 2) == FAILURE)
	return FAILURE;
      if (variable_check (zone, 2) == FAILURE)
	return FAILURE;
    }

  if (values != NULL)
    {
      if (type_check (values, 3, BT_INTEGER) == FAILURE)
	return FAILURE;
      if (array_check (values, 3) == FAILURE)
	return FAILURE;
      if (rank_check (values, 3, 1) == FAILURE)
	return FAILURE;
      if (variable_check (values, 3) == FAILURE)
	return FAILURE;
    }

  return SUCCESS;
}


try
gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len,
		  gfc_expr * to, gfc_expr * topos)
{
  if (type_check (from, 0, BT_INTEGER) == FAILURE)
    return FAILURE;

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

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

  if (same_type_check (from, 0, to, 3) == FAILURE)
    return FAILURE;

  if (variable_check (to, 3) == FAILURE)
    return FAILURE;

  if (type_check (topos, 4, BT_INTEGER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_random_number (gfc_expr * harvest)
{
  if (type_check (harvest, 0, BT_REAL) == FAILURE)
    return FAILURE;

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

  return SUCCESS;
}


try
gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
{
  if (size != NULL)
    {
      if (scalar_check (size, 0) == FAILURE)
	return FAILURE;

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