diff options
Diffstat (limited to 'gcc/fortran/arith.cc')
| -rw-r--r-- | gcc/fortran/arith.cc | 78 |
1 files changed, 73 insertions, 5 deletions
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index d57059a..14ba931 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -118,6 +118,9 @@ gfc_arith_error (arith code) case ARITH_WRONGCONCAT: p = G_("Illegal type in character concatenation at %L"); break; + case ARITH_INVALID_TYPE: + p = G_("Invalid type in arithmetic operation at %L"); + break; default: gfc_internal_error ("gfc_arith_error(): Bad error code"); @@ -621,6 +624,9 @@ gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; + if (op1->ts.type != op2->ts.type) + return ARITH_INVALID_TYPE; + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) @@ -655,6 +661,9 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; + if (op1->ts.type != op2->ts.type) + return ARITH_INVALID_TYPE; + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) @@ -689,6 +698,9 @@ gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; + if (op1->ts.type != op2->ts.type) + return ARITH_INVALID_TYPE; + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); switch (op1->ts.type) @@ -724,6 +736,9 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; + if (op1->ts.type != op2->ts.type) + return ARITH_INVALID_TYPE; + rc = ARITH_OK; result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); @@ -812,6 +827,9 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) gfc_expr *result; arith rc; + if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) + return ARITH_INVALID_TYPE; + rc = ARITH_OK; result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); @@ -1268,7 +1286,10 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, head = gfc_constructor_copy (op->value.constructor); for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { - rc = reduce_unary (eval, c->expr, &r); + if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN) + rc = ARITH_INVALID_TYPE; + else + rc = reduce_unary (eval, c->expr, &r); if (rc != ARITH_OK) break; @@ -1309,6 +1330,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (c->expr, op2, &r); + else if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN) + rc = ARITH_INVALID_TYPE; else rc = reduce_binary_ac (eval, c->expr, op2, &r); @@ -1361,6 +1384,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (op1, c->expr, &r); + else if (c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN) + rc = ARITH_INVALID_TYPE; else rc = reduce_binary_ca (eval, op1, c->expr, &r); @@ -1420,14 +1445,19 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), c && d; c = gfc_constructor_next (c), d = gfc_constructor_next (d)) { + if ((c->expr->expr_type == EXPR_OP && c->expr->ts.type == BT_UNKNOWN) + || (d->expr->expr_type == EXPR_OP && d->expr->ts.type == BT_UNKNOWN)) + rc = ARITH_INVALID_TYPE; + else rc = reduce_binary (eval, c->expr, d->expr, &r); - if (rc != ARITH_OK) - break; - gfc_replace_expr (c->expr, r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); } - if (c || d) + if (rc == ARITH_OK && (c || d)) rc = ARITH_INCOMMENSURATE; if (rc != ARITH_OK) @@ -1638,6 +1668,8 @@ eval_intrinsic (gfc_intrinsic_op op, else rc = reduce_binary (eval.f3, op1, op2, &result); + if (rc == ARITH_INVALID_TYPE) + goto runtime; /* Something went wrong. */ if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT) @@ -2023,6 +2055,9 @@ gfc_int2int (gfc_expr *src, int kind) gfc_expr *result; arith rc; + if (src->ts.type != BT_INTEGER) + return NULL; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set (result->value.integer, src->value.integer); @@ -2068,6 +2103,9 @@ gfc_int2real (gfc_expr *src, int kind) gfc_expr *result; arith rc; + if (src->ts.type != BT_INTEGER) + return NULL; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); @@ -2099,6 +2137,9 @@ gfc_int2complex (gfc_expr *src, int kind) gfc_expr *result; arith rc; + if (src->ts.type != BT_INTEGER) + return NULL; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); @@ -2133,6 +2174,9 @@ gfc_real2int (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_REAL) + return NULL; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); @@ -2179,6 +2223,9 @@ gfc_real2real (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_REAL) + return NULL; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); @@ -2238,6 +2285,9 @@ gfc_real2complex (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_REAL) + return NULL; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); @@ -2290,6 +2340,9 @@ gfc_complex2int (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_COMPLEX) + return NULL; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), @@ -2352,6 +2405,9 @@ gfc_complex2real (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_COMPLEX) + return NULL; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); @@ -2419,6 +2475,9 @@ gfc_complex2complex (gfc_expr *src, int kind) arith rc; bool did_warn = false; + if (src->ts.type != BT_COMPLEX) + return NULL; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); @@ -2484,6 +2543,9 @@ gfc_log2log (gfc_expr *src, int kind) { gfc_expr *result; + if (src->ts.type != BT_LOGICAL) + return NULL; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = src->value.logical; @@ -2498,6 +2560,9 @@ gfc_log2int (gfc_expr *src, int kind) { gfc_expr *result; + if (src->ts.type != BT_LOGICAL) + return NULL; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); mpz_set_si (result->value.integer, src->value.logical); @@ -2512,6 +2577,9 @@ gfc_int2log (gfc_expr *src, int kind) { gfc_expr *result; + if (src->ts.type != BT_INTEGER) + return NULL; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); |