check.c

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

/* Check functions
   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Andy Vaught & Katherine Holcomb

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


/* These functions check to see if an argument list is compatible with
   a particular intrinsic function or subroutine.  Presence of
   required arguments has already been established, the argument list
   has been sorted into the right order and has NULL arguments in the
   correct places for missing optional arguments.  */

#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"


/* Check the type of an expression.  */

static try
type_check (gfc_expr * e, int n, bt type)
{
  if (e->ts.type == type)
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where,
	     gfc_basic_typename (type));

  return FAILURE;
}


/* Check that the expression is a numeric type.  */

static try
numeric_check (gfc_expr * e, int n)
{
  if (gfc_numeric_ts (&e->ts))
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a numeric type",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);

  return FAILURE;
}


/* Check that an expression is integer or real.  */

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

  return SUCCESS;
}


/* Check that an expression is real or complex.  */

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

  return SUCCESS;
}


/* Check that the expression is an optional constant integer
   and that it specifies a valid kind for that type.  */

static try
kind_check (gfc_expr * k, int n, bt type)
{
  int kind;

  if (k == NULL)
    return SUCCESS;

  if (type_check (k, n, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (k->expr_type != EXPR_CONSTANT)
    {
      gfc_error (
	"'%s' argument of '%s' intrinsic at %L must be a constant",
	gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &k->where);
      return FAILURE;
    }

  if (gfc_extract_int (k, &kind) != NULL
      || gfc_validate_kind (type, kind, true) < 0)
    {
      gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type),
		 &k->where);
      return FAILURE;
    }

  return SUCCESS;
}


/* Make sure the expression is a double precision real.  */

static try
double_check (gfc_expr * d, int n)
{
  if (type_check (d, n, BT_REAL) == FAILURE)
    return FAILURE;

  if (d->ts.kind != gfc_default_double_kind)
    {
      gfc_error (
	"'%s' argument of '%s' intrinsic at %L must be double precision",
	gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &d->where);
      return FAILURE;
    }

  return SUCCESS;
}


/* Make sure the expression is a logical array.  */

static try
logical_array_check (gfc_expr * array, int n)
{
  if (array->ts.type != BT_LOGICAL || array->rank == 0)
    {
      gfc_error (
	"'%s' argument of '%s' intrinsic at %L must be a logical array",
	gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &array->where);
      return FAILURE;
    }

  return SUCCESS;
}


/* Make sure an expression is an array.  */

static try
array_check (gfc_expr * e, int n)
{
  if (e->rank != 0)
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be an array",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);

  return FAILURE;
}


/* Make sure an expression is a scalar.  */

static try
scalar_check (gfc_expr * e, int n)
{
  if (e->rank == 0)
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a scalar",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);

  return FAILURE;
}


/* Make sure two expression have the same type.  */

static try
same_type_check (gfc_expr * e, int n, gfc_expr * f, int m)
{
  if (gfc_compare_types (&e->ts, &f->ts))
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be the same type "
	     "and kind as '%s'", gfc_current_intrinsic_arg[m],
	     gfc_current_intrinsic, &f->where, gfc_current_intrinsic_arg[n]);
  return FAILURE;
}


/* Make sure that an expression has a certain (nonzero) rank.  */

static try
rank_check (gfc_expr * e, int n, int rank)
{
  if (e->rank == rank)
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of rank %d",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
	     &e->where, rank);
  return FAILURE;
}


/* Make sure a variable expression is not an optional dummy argument.  */

static try
nonoptional_check (gfc_expr * e, int n)
{
  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL",
		 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
		 &e->where);

    }

  /* TODO: Recursive check on nonoptional variables?  */

  return SUCCESS;
}


/* Check that an expression has a particular kind.  */

static try
kind_value_check (gfc_expr * e, int n, int k)
{
  if (e->ts.kind == k)
    return SUCCESS;

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be of kind %d",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
	     &e->where, k);
  return FAILURE;
}


/* Make sure an expression is a variable.  */

static try
variable_check (gfc_expr * e, int n)
{
  if ((e->expr_type == EXPR_VARIABLE
       && e->symtree->n.sym->attr.flavor != FL_PARAMETER)
      || (e->expr_type == EXPR_FUNCTION
	  && e->symtree->n.sym->result == e->symtree->n.sym))
    return SUCCESS;

  if (e->expr_type == EXPR_VARIABLE
      && e->symtree->n.sym->attr.intent == INTENT_IN)
    {
      gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
		 gfc_current_intrinsic_arg[n], gfc_current_intrinsic,
		 &e->where);
      return FAILURE;
    }

  gfc_error ("'%s' argument of '%s' intrinsic at %L must be a variable",
	     gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where);

  return FAILURE;
}


/* Check the common DIM parameter for correctness.  */

static try
dim_check (gfc_expr * dim, int n, int optional)
{
  if (optional)
    {
      if (dim == NULL)
	return SUCCESS;

      if (nonoptional_check (dim, n) == FAILURE)
	return FAILURE;

      return SUCCESS;
    }

  if (dim == NULL)
    {
      gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
		 gfc_current_intrinsic, gfc_current_intrinsic_where);
      return FAILURE;
    }

  if (type_check (dim, n, BT_INTEGER) == FAILURE)
    return FAILURE;

  if (scalar_check (dim, n) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* If a DIM parameter is a constant, make sure that it is greater than
   zero and less than or equal to the rank of the given array.  If
   allow_assumed is zero then dim must be less than the rank of the array
   for assumed size arrays.  */

static try
dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
{
  gfc_array_ref *ar;
  int rank;

  if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE)
    return SUCCESS;

  ar = gfc_find_array_ref (array);
  rank = array->rank;
  if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed)
    rank--;

  if (mpz_cmp_ui (dim->value.integer, 1) < 0
      || mpz_cmp_ui (dim->value.integer, rank) > 0)
    {
      gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
		 "dimension index", gfc_current_intrinsic, &dim->where);

      return FAILURE;
    }

  return SUCCESS;
}

/***** Check functions *****/

/* Check subroutine suitable for intrinsics taking a real argument and
   a kind argument for the result.  */

static try
check_a_kind (gfc_expr * a, gfc_expr * kind, bt type)
{
  if (type_check (a, 0, BT_REAL) == FAILURE)
    return FAILURE;
  if (kind_check (kind, 1, type) == FAILURE)
    return FAILURE;

  return SUCCESS;
}

/* Check subroutine suitable for ceiling, floor and nint.  */

try
gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind)
{
  return check_a_kind (a, kind, BT_INTEGER);
}

/* Check subroutine suitable for aint, anint.  */

try
gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind)
{
  return check_a_kind (a, kind, BT_REAL);
}

try
gfc_check_abs (gfc_expr * a)
{
  if (numeric_check (a, 0) == FAILURE)
    return FAILURE;

  return SUCCESS;
}

try
gfc_check_achar (gfc_expr * a)
{

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

  return SUCCESS;
}


try
gfc_check_all_any (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_allocated (gfc_expr * array)
{
  if (variable_check (array, 0) == FAILURE)
    return FAILURE;

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

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

  return SUCCESS;
}


/* Common check function where the first argument must be real or
   integer and the second argument must be the same as the first.  */

try
gfc_check_a_p (gfc_expr * a, gfc_expr * p)
{
  if (int_or_real_check (a, 0) == FAILURE)
    return FAILURE;

  if (a->ts.type != p->ts.type)
    {
      gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
                "have the same type", gfc_current_intrinsic_arg[0],
                gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
                &p->where);
      return FAILURE;
    }

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

  return SUCCESS;
}


try
gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
{
  symbol_attribute attr;
  int i;
  try t;

  if (pointer->expr_type == EXPR_VARIABLE)
    attr = gfc_variable_attr (pointer, NULL);
  else if (pointer->expr_type == EXPR_FUNCTION)
    attr = pointer->symtree->n.sym->attr;
  else
    gcc_assert (0); /* Pointer must be a variable or a function.  */

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

  /* Target argument is optional.  */
  if (target == NULL)
    return SUCCESS;

  if (target->expr_type == EXPR_NULL)
    {
      gfc_error ("NULL pointer at %L is not permitted as actual argument "
                 "of '%s' intrinsic function",
                 &target->where, gfc_current_intrinsic);
      return FAILURE;
    }

  if (target->expr_type == EXPR_VARIABLE)
    attr = gfc_variable_attr (target, NULL);
  else if (target->expr_type == EXPR_FUNCTION)
    attr = target->symtree->n.sym->attr;
  else
    gcc_assert (0); /* Target must be a variable or a function.  */

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

  t = SUCCESS;
  if (same_type_check (pointer, 0, target, 1) == FAILURE)
    t = FAILURE;
  if (rank_check (target, 0, pointer->rank) == FAILURE)
    t = FAILURE;
  if (target->rank > 0)
    {
      for (i = 0; i < target->rank; i++)
        if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
          {
            gfc_error ("Array section with a vector subscript at %L shall not "
		       "be the target of a pointer",
                       &target->where);
            t = FAILURE;
            break;
          }
    }
  return t;
}


try
gfc_check_atan2 (gfc_expr * y, gfc_expr * x)
{
  if (type_check (y, 0, BT_REAL) == FAILURE)
    return FAILURE;
  if (same_type_check (y, 0, x, 1) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


/* BESJN and BESYN functions.  */

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

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

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

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

  return SUCCESS;
}


try
gfc_check_btest (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_char (gfc_expr * i, gfc_expr * kind)
{
  if (type_check (i, 0, BT_INTEGER) == FAILURE)
    return FAILURE;
  if (kind_check (kind, 1, BT_CHARACTER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


try
gfc_check_chdir (gfc_expr * dir)
{
  if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


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

  if (status == NULL)
    return SUCCESS;

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

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

  return SUCCESS;
}