gfc_expr gfc_bad_expr;
+static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);
+
/* Note that 'simplification' is not just transforming expressions.
For functions that are not simplified at compile time, range
}
-/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
+/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
+ if conj_a is true, the matrix_a is complex conjugated. */
static gfc_expr *
compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
- gfc_expr *matrix_b, int stride_b, int offset_b)
+ gfc_expr *matrix_b, int stride_b, int offset_b,
+ bool conj_a)
{
- gfc_expr *result, *a, *b;
+ gfc_expr *result, *a, *b, *c;
result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
&matrix_a->where);
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
- result = gfc_add (result,
- gfc_multiply (gfc_copy_expr (a),
- gfc_copy_expr (b)));
+ if (conj_a && a->ts.type == BT_COMPLEX)
+ c = gfc_simplify_conjg (a);
+ else
+ c = gfc_copy_expr (a);
+ result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
break;
default:
gcc_assert (vector_b->rank == 1);
gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
- return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
+ return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
}
gfc_expr* dim = result;
mpz_set_si (dim->value.integer, d);
- result = gfc_simplify_size (array, dim, kind);
+ result = simplify_size (array, dim, k);
gfc_free_expr (dim);
if (!result)
goto returnNull;
gcc_assert (array->expr_type == EXPR_VARIABLE);
gcc_assert (as);
+ if (gfc_resolve_array_spec (as, 0) == FAILURE)
+ return NULL;
+
/* The last dimension of an assumed-size array is special. */
if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
|| (coarray && d == as->rank + as->corank
if (matrix_a->rank == 1 && matrix_b->rank == 2)
{
result_rows = 1;
- result_columns = mpz_get_si (matrix_b->shape[0]);
+ result_columns = mpz_get_si (matrix_b->shape[1]);
stride_a = 1;
stride_b = mpz_get_si (matrix_b->shape[0]);
}
else if (matrix_a->rank == 2 && matrix_b->rank == 1)
{
- result_rows = mpz_get_si (matrix_b->shape[0]);
+ result_rows = mpz_get_si (matrix_a->shape[0]);
result_columns = 1;
stride_a = mpz_get_si (matrix_a->shape[0]);
stride_b = 1;
{
result_rows = mpz_get_si (matrix_a->shape[0]);
result_columns = mpz_get_si (matrix_b->shape[1]);
- stride_a = mpz_get_si (matrix_a->shape[1]);
+ stride_a = mpz_get_si (matrix_a->shape[0]);
stride_b = mpz_get_si (matrix_b->shape[0]);
result->rank = 2;
for (row = 0; row < result_rows; ++row)
{
gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
- matrix_b, 1, offset_b);
+ matrix_b, 1, offset_b, false);
gfc_constructor_append_expr (&result->value.constructor,
e, NULL);
e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
if (t == SUCCESS)
- {
- mpz_set (e->value.integer, shape[n]);
- mpz_clear (shape[n]);
- }
+ mpz_set (e->value.integer, shape[n]);
else
{
mpz_set_ui (e->value.integer, n + 1);
- f = gfc_simplify_size (source, e, NULL);
+ f = simplify_size (source, e, k);
gfc_free_expr (e);
if (f == NULL)
{
e = f;
}
+ if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
+ {
+ gfc_free_expr (result);
+ if (t == SUCCESS)
+ gfc_clear_shape (shape, source->rank);
+ return &gfc_bad_expr;
+ }
+
gfc_constructor_append_expr (&result->value.constructor, e, NULL);
}
+ if (t == SUCCESS)
+ gfc_clear_shape (shape, source->rank);
+
return result;
}
-gfc_expr *
-gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+static gfc_expr *
+simplify_size (gfc_expr *array, gfc_expr *dim, int k)
{
mpz_t size;
gfc_expr *return_value;
int d;
- int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
-
- if (k == -1)
- return &gfc_bad_expr;
/* For unary operations, the size of the result is given by the size
of the operand. For binary ones, it's the size of the first operand
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
replacement = array->value.op.op1;
break;
replacement = array->value.op.op1;
else
{
- simplified = gfc_simplify_size (array->value.op.op1, dim, kind);
+ simplified = simplify_size (array->value.op.op1, dim, k);
if (simplified)
return simplified;
}
/* Try to reduce it directly if possible. */
- simplified = gfc_simplify_size (replacement, dim, kind);
+ simplified = simplify_size (replacement, dim, k);
/* Otherwise, we build a new SIZE call. This is hopefully at least
simpler than the original one. */
if (!simplified)
- simplified = gfc_build_intrinsic_call ("size", array->where, 3,
- gfc_copy_expr (replacement),
- gfc_copy_expr (dim),
- gfc_copy_expr (kind));
-
+ {
+ gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
+ simplified = gfc_build_intrinsic_call (gfc_current_ns,
+ GFC_ISYM_SIZE, "size",
+ array->where, 3,
+ gfc_copy_expr (replacement),
+ gfc_copy_expr (dim),
+ kind);
+ }
return simplified;
}
return NULL;
}
- return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
+ mpz_set (return_value->value.integer, size);
mpz_clear (size);
+
return return_value;
}
gfc_expr *
+gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ gfc_expr *result;
+ int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
+
+ if (k == -1)
+ return &gfc_bad_expr;
+
+ result = simplify_size (array, dim, k);
+ if (result == NULL || result == &gfc_bad_expr)
+ return result;
+
+ return range_check (result, "SIZE");
+}
+
+
+gfc_expr *
gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
OSDN Git Service
