diff options
| author | Thomas Koenig <tkoenig@gcc.gnu.org> | 2018-11-18 09:16:19 +0000 |
|---|---|---|
| committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2018-11-18 09:16:19 +0000 |
| commit | 83fad92900e6370e4ca4f40cefe56a386399239d (patch) | |
| tree | 733da04272d4bc40f47098cfc29208db9487f595 /gcc/fortran/expr.c | |
| parent | f163ea822bbd36328ae2af9c47f2fa05ab1077f1 (diff) | |
| download | gcc-83fad92900e6370e4ca4f40cefe56a386399239d.zip gcc-83fad92900e6370e4ca4f40cefe56a386399239d.tar.gz gcc-83fad92900e6370e4ca4f40cefe56a386399239d.tar.bz2 | |
re PR fortran/70260 (ICE: gimplification failed)
2018-11-18 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/70260
* expr.c (gfc_check_assign): Reject assigning to an external
symbol.
(gfc_check_pointer_assign): Add suppress_type_test
argument. Insert line after if. A non-proc pointer can not point
to a constant. Only check types if suppress_type_test is false.
* gfortran.h (gfc_check_pointer_assign): Add optional
suppress_type_test argument.
* resolve.c (gfc_resolve_code): Move up gfc_check_pointer_assign
and give it the extra argument.
(resolve_fl_procedure): Set error on value for a function with
an inizializer.
2018-11-18 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/70260
* gfortran.dg/proc_ptr_result_5.f90: Add dg-error directive.
* gfortran.dg/protected_4.f90: Split line to allow for extra error.
* gfortran.dg/protected_6.f90: Likewise.
* gfortran.dg/assign_11.f90: New test.
* gfortran.dg/pointer_assign_12.f90: New test.
From-SVN: r266248
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 28 |
1 files changed, 26 insertions, 2 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 1d1d48d..388fdda 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3507,6 +3507,18 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, return false; } } + else + { + /* Reject assigning to an external symbol. For initializers, this + was already done before, in resolve_fl_procedure. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external + && sym->attr.proc != PROC_MODULE && !rvalue->error) + { + gfc_error ("Illegal assignment to external procedure at %L", + &lvalue->where); + return false; + } + } if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) { @@ -3643,7 +3655,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, NULLIFY statement. */ bool -gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) +gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, + bool suppress_type_test) { symbol_attribute attr, lhs_attr; gfc_ref *ref; @@ -3771,6 +3784,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) &rvalue->where); return false; } + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) { /* Check for intrinsics. */ @@ -3967,6 +3981,16 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return true; } + else + { + /* A non-proc pointer cannot point to a constant. */ + if (rvalue->expr_type == EXPR_CONSTANT) + { + gfc_error_now ("Pointer assignment target cannot be a constant at %L", + &rvalue->where); + return false; + } + } if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { @@ -3980,7 +4004,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) "polymorphic, or of a type with the BIND or SEQUENCE " "attribute, to be compatible with an unlimited " "polymorphic target", &lvalue->where); - else + else if (!suppress_type_test) gfc_error ("Different types in pointer assignment at %L; " "attempted assignment of %s to %s", &lvalue->where, gfc_typename (&rvalue->ts), |