/* 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 *****/
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 "
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;
}
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)
{