/* Check functions
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
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 (optional && dim == NULL)
+ return SUCCESS;
if (dim == NULL)
{
if (scalar_check (dim, n) == FAILURE)
return FAILURE;
+ if (nonoptional_check (dim, n) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
return SUCCESS;
}
+/* Compare the size of a along dimension ai with the size of b along
+ dimension bi, returning 0 if they are known not to be identical,
+ and 1 if they are identical, or if this cannot be determined. */
+
+static int
+identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
+{
+ mpz_t a_size, b_size;
+ int ret;
+
+ gcc_assert (a->rank > ai);
+ gcc_assert (b->rank > bi);
+
+ ret = 1;
+
+ if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
+ {
+ if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
+ {
+ if (mpz_cmp (a_size, b_size) != 0)
+ ret = 0;
+
+ mpz_clear (b_size);
+ }
+ mpz_clear (a_size);
+ }
+ return ret;
+}
/***** Check functions *****/
if (int_or_real_check (a, 0) == FAILURE)
return FAILURE;
- if (same_type_check (a, 0, p, 1) == 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;
}
int i;
try t;
- if (variable_check (pointer, 0) == FAILURE)
- return FAILURE;
+ 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. */
- attr = gfc_variable_attr (pointer, NULL);
if (!attr.pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
return FAILURE;
}
+ /* Target argument is optional. */
if (target == NULL)
return SUCCESS;
- /* Target argument is optional. */
if (target->expr_type == EXPR_NULL)
{
gfc_error ("NULL pointer at %L is not permitted as actual argument "
return FAILURE;
}
- attr = gfc_variable_attr (target, NULL);
+ 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 "
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)
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)
if (rank_check (vector_b, 1, 1) == FAILURE)
return FAILURE;
+ if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
+ {
+ gfc_error ("different shape for arguments '%s' and '%s' "
+ "at %L for intrinsic 'dot_product'",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ &vector_a->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
return SUCCESS;
}
+try
+gfc_check_loc (gfc_expr *expr)
+{
+ return variable_check (expr, 0);
+}
+
try
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
/* 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)
case 1:
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
+ /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
+ if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 1 for arguments '%s' "
+ "and '%s' at %L for intrinsic matmul",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ &matrix_a->where);
+ return FAILURE;
+ }
break;
case 2:
- if (matrix_b->rank == 2)
- break;
- if (rank_check (matrix_b, 1, 1) == FAILURE)
- return FAILURE;
+ if (matrix_b->rank != 2)
+ {
+ if (rank_check (matrix_b, 1, 1) == FAILURE)
+ return FAILURE;
+ }
+ /* matrix_b has rank 1 or 2 here. Common check for the cases
+ - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+ - matrix_a has shape (n,m) and matrix_b has shape (m). */
+ if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 2 for argument '%s' and "
+ "dimension 1 for argument '%s' at %L for intrinsic "
+ "matmul", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &matrix_a->where);
+ return FAILURE;
+ }
break;
default:
ap->next->next->expr = m;
}
- if (d != NULL
- && (scalar_check (d, 1) == FAILURE
- || type_check (d, 1, BT_INTEGER) == FAILURE))
+ if (dim_check (d, 1, 1) == FAILURE)
+ return FAILURE;
+
+ if (d && dim_rank_check (d, a, 0) == 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;
}
static try
check_reduction (gfc_actual_arglist * ap)
{
- gfc_expr *m, *d;
+ gfc_expr *a, *m, *d;
+ a = ap->expr;
d = ap->next->expr;
m = ap->next->next->expr;
ap->next->next->expr = m;
}
- if (d != NULL
- && (scalar_check (d, 1) == FAILURE
- || type_check (d, 1, BT_INTEGER) == FAILURE))
+ if (dim_check (d, 1, 1) == FAILURE)
+ return FAILURE;
+
+ if (d && dim_rank_check (d, a, 0) == 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_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
{
+ char buffer[80];
+
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
+ return FAILURE;
+
+ 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, tsource, mask) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
{
+ char buffer[80];
+
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;
- }
+ snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+ return FAILURE;
if (vector != NULL)
{
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)
{
}
+/* 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)
{
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)
}
+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. */
return SUCCESS;
}
+
+try
+gfc_check_alarm_sub (gfc_expr * seconds, gfc_expr * handler, gfc_expr * status)
+{
+ if (scalar_check (seconds, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
+ {
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ return FAILURE;
+ }
+
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (scalar_check (status, 2) == FAILURE)
+ return FAILURE;
+
+ if (type_check (status, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
try
gfc_check_rand (gfc_expr * x)
{
}
try
+gfc_check_ctime_sub (gfc_expr * time, gfc_expr * result)
+{
+ if (scalar_check (time, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (time, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (type_check (result, 1, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+try
gfc_check_etime (gfc_expr * x)
{
if (array_check (x, 0) == FAILURE)
try
+gfc_check_fdate_sub (gfc_expr * date)
+{
+ if (type_check (date, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
gfc_check_gerror (gfc_expr * msg)
{
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
try
+gfc_check_free (gfc_expr * i)
+{
+ if (type_check (i, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (i, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
gfc_check_hostnm (gfc_expr * name)
{
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
try
+gfc_check_signal (gfc_expr * number, gfc_expr * handler)
+{
+ if (scalar_check (number, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (number, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
+ {
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ return FAILURE;
+ }
+
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_signal_sub (gfc_expr * number, gfc_expr * handler, gfc_expr * status)
+{
+ if (scalar_check (number, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (number, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (handler->ts.type != BT_INTEGER && handler->ts.type != BT_PROCEDURE)
+ {
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or PROCEDURE",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &handler->where);
+ return FAILURE;
+ }
+
+ if (handler->ts.type == BT_INTEGER && scalar_check (handler, 1) == 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_system_sub (gfc_expr * cmd, gfc_expr * status)
{
if (type_check (cmd, 0, BT_CHARACTER) == FAILURE)
return SUCCESS;
}
+
+
+/* This is used for the GNU intrinsics AND, OR and XOR. */
+try
+gfc_check_and (gfc_expr * i, gfc_expr * j)
+{
+ if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
+ {
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
+ return FAILURE;
+ }
+
+ if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
+ {
+ gfc_error (
+ "'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
+ return FAILURE;
+ }
+
+ if (i->ts.type != j->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,
+ &j->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (i, 0) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (j, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
OSDN Git Service
