From 83fad92900e6370e4ca4f40cefe56a386399239d Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Sun, 18 Nov 2018 09:16:19 +0000 Subject: [PATCH] re PR fortran/70260 (ICE: gimplification failed) 2018-11-18 Thomas Koenig 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 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 --- gcc/fortran/ChangeLog | 15 ++++++++++ gcc/fortran/expr.c | 28 +++++++++++++++++-- gcc/fortran/gfortran.h | 3 +- gcc/fortran/resolve.c | 8 ++++-- gcc/testsuite/ChangeLog | 9 ++++++ gcc/testsuite/gfortran.dg/assign_11.f90 | 9 ++++++ .../gfortran.dg/pointer_assign_12.f90 | 15 ++++++++++ .../gfortran.dg/proc_ptr_result_5.f90 | 2 +- gcc/testsuite/gfortran.dg/protected_4.f90 | 3 +- gcc/testsuite/gfortran.dg/protected_6.f90 | 3 +- 10 files changed, 87 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/assign_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_assign_12.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2868db9f6a0..83920ab8f6d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2018-11-18 Thomas Koenig + + 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-15 David Malcolm PR other/19165 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 1d1d48d0b81..388fddab472 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), diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 128f5746aa9..530e00794fb 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3219,7 +3219,8 @@ int gfc_kind_max (gfc_expr *, gfc_expr *); bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3; bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true); -bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *); +bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, + bool suppres_type_test = false); bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *); gfc_expr *gfc_build_default_init_expr (gfc_typespec *, locus *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ba9623497d2..df7c6cb13ac 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11420,11 +11420,12 @@ start: t = gfc_check_vardef_context (e, false, false, false, _("pointer assignment")); gfc_free_expr (e); + + t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; + if (!t) break; - gfc_check_pointer_assign (code->expr1, code->expr2); - /* Assigning a class object always is a regular assign. */ if (code->expr2->ts.type == BT_CLASS && code->expr1->ts.type == BT_CLASS @@ -12540,6 +12541,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { gfc_error ("Function %qs at %L cannot have an initializer", sym->name, &sym->declared_at); + + /* Make sure no second error is issued for this. */ + sym->value->error = 1; return false; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 30386c6fa89..571618623e7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2018-11-18 Thomas Koenig + + 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. + 2018-11-17 Jakub Jelinek PR tree-optimization/87546 diff --git a/gcc/testsuite/gfortran.dg/assign_11.f90 b/gcc/testsuite/gfortran.dg/assign_11.f90 new file mode 100644 index 00000000000..81c0286c4f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assign_11.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 70260 - this used to ICE +! Original test case by Gernard Steinmetz +subroutine s (f) + integer, external :: f, g + integer :: h + g = f(2) ! { dg-error "Illegal assignment to external procedure" } + h = g(2) +end diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_12.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_12.f90 new file mode 100644 index 00000000000..d2ed3d3e369 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_12.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR 70260 - this used to ICE +! Original test case by Gehard Steinmetz +module m + interface gkind + procedure g + end interface +contains + integer function g() + g => 1 ! { dg-error "Pointer assignment target cannot be a constant" } + end + subroutine f(x) + character(kind=kind(gkind())) :: x + end +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 index 121fd4d87f9..36afedf58c7 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 @@ -14,6 +14,6 @@ contains logical(1) function f() end function end interface - f = .true._1 + f = .true._1 ! { dg-error "Illegal assignment" } end function f end program test diff --git a/gcc/testsuite/gfortran.dg/protected_4.f90 b/gcc/testsuite/gfortran.dg/protected_4.f90 index 44ca6ac1392..46e508522b7 100644 --- a/gcc/testsuite/gfortran.dg/protected_4.f90 +++ b/gcc/testsuite/gfortran.dg/protected_4.f90 @@ -26,7 +26,8 @@ program main a = 43 ! { dg-error "variable definition context" } ap => null() ! { dg-error "pointer association context" } nullify(ap) ! { dg-error "pointer association context" } - ap => at ! { dg-error "pointer association context" } + ap => & ! { dg-error "pointer association context" } + & at ! { dg-error "Pointer assignment target has PROTECTED attribute" } ap = 3 ! OK allocate(ap) ! { dg-error "pointer association context" } ap = 73 ! OK diff --git a/gcc/testsuite/gfortran.dg/protected_6.f90 b/gcc/testsuite/gfortran.dg/protected_6.f90 index 9df9ef47a10..b386dcf5f1b 100644 --- a/gcc/testsuite/gfortran.dg/protected_6.f90 +++ b/gcc/testsuite/gfortran.dg/protected_6.f90 @@ -22,7 +22,8 @@ program main a = 43 ! { dg-error "variable definition context" } ap => null() ! { dg-error "pointer association context" } nullify(ap) ! { dg-error "pointer association context" } - ap => at ! { dg-error "pointer association context" } + ap => & ! { dg-error "pointer association context" } + & at ! { dg-error "Pointer assignment target has PROTECTED attribute" } ap = 3 ! OK allocate(ap) ! { dg-error "pointer association context" } ap = 73 ! OK -- 2.30.2