This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[fortran, patch] PR34714 - fix ice-on-invalid
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Thu, 20 Mar 2008 21:58:22 +0100
- Subject: [fortran, patch] PR34714 - fix ice-on-invalid
- Dkim-signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=beta; h=domainkey-signature:received:received:from:to:subject:date:user-agent:mime-version:content-type:message-id; bh=tOhzne96bhP/jk9R1gkyPh3+2AnwOMzhrxSLNQklac4=; b=nYlZohvkcnnvzDLIymt4NWAUP/3pjFe3JHr81PkBdxUY10ftjFdW0gBCdovGy79th4N2AwKDpf5sPa8+U4RDXDE1vDgzAUDVty3G2MYjaz2xyegOtTEUJCo3y96g1GsxlB3HhOo0zhnLGN4GEitrcLnE1H0EQC2SKpgawYP0Z6s=
- Domainkey-signature: a=rsa-sha1; c=nofws; d=gmail.com; s=beta; h=from:to:subject:date:user-agent:mime-version:content-type:message-id; b=FzXkwmtA+XQ3O7JVLukrhwGm3xCC7TXGlhZikbO109f+Te7fmZkNO09InjyFJ+R5Fo4n6T7aXLUPWWjTVLTO42xe5tAojjOvyZdnfseP6ikP4fAM+DG7mxddPWs9UwcIomIlHfeTWZr5LEqrjVPcv4h3HdaN3Mc6s6z/7goVoc4=
Thanks to Paul who gave me a leg-up with this :)
gcc/fortran:
2008-03-20 Daniel Franke <franke.daniel@gmail.com>
Paul Richard Thomas <paul.richard.thomas@gmail.com>
PR fortran/34714
* primary.c (match_variable): Improved matching of function
result variables.
* resolve.c (resolve_allocate_deallocate): Removed checks if the
actual argument for STAT is a variable.
gcc/testsuite:
2008-03-20 Daniel Franke <franke.daniel@gmail.com>
Paul Richard Thomas <paul.richard.thomas@gmail.com>
PR fortran/34714
* gfortran.dg/alloc_alloc_expr_3.f90: New test.
* gfortran.dg/allocate_stat.f90: Adjusted error-match text.
* gfortran.dg/func_assign.f90: Likewise.
* gfortran.dg/implicit_11.f90: Likewise.
* gfortran.dg/proc_assign_1.f90: Likewise.
* gfortran.dg/proc_assign_2.f90: Likewise.
* gfortran.dg/procedure_lvalue.f90: Likewise.
Bootstrapped and regression tested on i686-pc-linux-gnu.
Ok for trunk (and maybe 4.3)?
Regards
Daniel
Index: fortran/primary.c
===================================================================
--- fortran/primary.c (revision 133396)
+++ fortran/primary.c (working copy)
@@ -2561,8 +2561,18 @@ match_variable (gfc_expr **result, int e
break;
case FL_PROCEDURE:
- /* Check for a nonrecursive function result */
- if (sym->attr.function && sym->result == sym && !sym->attr.external)
+ /* Check for a nonrecursive function result variable. */
+ if (sym->attr.function
+ && !sym->attr.external
+ && sym->result == sym
+ && ((sym == gfc_current_ns->proc_name
+ && sym == gfc_current_ns->proc_name->result)
+ || (gfc_current_ns->parent
+ && sym == gfc_current_ns->parent->proc_name->result)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns->parent)))
{
/* If a function result is a derived type, then the derived
type may still have to be resolved. */
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c (revision 133396)
+++ fortran/resolve.c (working copy)
@@ -4868,7 +4868,6 @@ resolve_allocate_deallocate (gfc_code *c
{
gfc_symbol *s = NULL;
gfc_alloc *a;
- bool is_variable;
if (code->expr)
s = code->expr->symtree->n.sym;
@@ -4882,45 +4881,6 @@ resolve_allocate_deallocate (gfc_code *c
if (gfc_pure (NULL) && gfc_impure_variable (s))
gfc_error ("Illegal STAT variable in %s statement at %C "
"for a PURE procedure", fcn);
-
- is_variable = false;
- if (s->attr.flavor == FL_VARIABLE)
- is_variable = true;
- else if (s->attr.function && s->result == s
- && (gfc_current_ns->proc_name == s
- ||
- (gfc_current_ns->parent
- && gfc_current_ns->parent->proc_name == s)))
- is_variable = true;
- else if (gfc_current_ns->entries && s->result == s)
- {
- gfc_entry_list *el;
- for (el = gfc_current_ns->entries; el; el = el->next)
- if (el->sym == s)
- {
- is_variable = true;
- }
- }
- else if (gfc_current_ns->parent && gfc_current_ns->parent->entries
- && s->result == s)
- {
- gfc_entry_list *el;
- for (el = gfc_current_ns->parent->entries; el; el = el->next)
- if (el->sym == s)
- {
- is_variable = true;
- }
- }
-
- if (s->attr.flavor == FL_UNKNOWN
- && gfc_add_flavor (&s->attr, FL_VARIABLE,
- s->name, NULL) == SUCCESS)
- is_variable = true;
-
- if (!is_variable)
- gfc_error ("STAT tag in %s statement at %L must be "
- "a variable", fcn, &code->expr->where);
-
}
if (s && code->expr->ts.type != BT_INTEGER)
Index: testsuite/gfortran.dg/alloc_alloc_expr_3.f90
===================================================================
--- testsuite/gfortran.dg/alloc_alloc_expr_3.f90 (revision 0)
+++ testsuite/gfortran.dg/alloc_alloc_expr_3.f90 (revision 0)
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! PR fortran/34714 - ICE on invalid
+! Testcase contributed by Martin Reinecke <martin AT mpa-garching DOT mpg DOT de>
+!
+
+module foo
+ type bar
+ logical, pointer, dimension(:) :: baz
+ end type
+contains
+
+function func1()
+ type(bar) func1
+ allocate(func1%baz(1))
+end function
+
+function func2()
+ type(bar) func2
+ allocate(func1%baz(1)) ! { dg-error "is not a variable" }
+end function
+
+end module foo
+
+! { dg-final { cleanup-modules "foo" } }
Index: testsuite/gfortran.dg/allocate_stat.f90
===================================================================
--- testsuite/gfortran.dg/allocate_stat.f90 (revision 133396)
+++ testsuite/gfortran.dg/allocate_stat.f90 (working copy)
@@ -51,7 +51,7 @@ subroutine sub()
end interface
real, pointer :: gain
integer, parameter :: res = 2
- allocate (gain,STAT=func2) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+ allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
deallocate(gain)
end subroutine sub
@@ -68,9 +68,9 @@ contains
end function one
subroutine sub()
integer, pointer :: p
- allocate(p, stat=one) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+ allocate(p, stat=one) ! { dg-error "is not a variable" }
if(associated(p)) deallocate(p)
- allocate(p, stat=two) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+ allocate(p, stat=two) ! { dg-error "is not a variable" }
if(associated(p)) deallocate(p)
end subroutine sub
end module test
Index: testsuite/gfortran.dg/func_assign.f90
===================================================================
--- testsuite/gfortran.dg/func_assign.f90 (revision 133396)
+++ testsuite/gfortran.dg/func_assign.f90 (working copy)
@@ -25,8 +25,8 @@ contains
end interface
sub = 'a' ! { dg-error "is not a variable" }
fun = 4.4 ! { dg-error "is not a variable" }
- funget = 4 ! { dg-error "is not a VALUE" }
- bar = 5 ! { dg-error "is not a VALUE" }
+ funget = 4 ! { dg-error "is not a variable" }
+ bar = 5 ! { dg-error "is not a variable" }
end subroutine a
end module mod
Index: testsuite/gfortran.dg/implicit_11.f90
===================================================================
--- testsuite/gfortran.dg/implicit_11.f90 (revision 133396)
+++ testsuite/gfortran.dg/implicit_11.f90 (working copy)
@@ -31,7 +31,7 @@
SUBROUTINE AD0001
REAL RLA1(:)
ALLOCATABLE RLA1
- ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "must be a variable" }
+ ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "is not a variable" }
END SUBROUTINE
END MODULE tests2
Index: testsuite/gfortran.dg/proc_assign_1.f90
===================================================================
--- testsuite/gfortran.dg/proc_assign_1.f90 (revision 133396)
+++ testsuite/gfortran.dg/proc_assign_1.f90 (working copy)
@@ -30,11 +30,11 @@ contains
end subroutine foobar
end function foo
subroutine bar() ! This was the original bug.
- foo = 10 ! { dg-error "is not a VALUE" }
+ foo = 10 ! { dg-error "is not a variable" }
end subroutine bar
integer function oh_no ()
oh_no = 1
- foo = 5 ! { dg-error "is not a VALUE" }
+ foo = 5 ! { dg-error "is not a variable" }
end function oh_no
end module simple
@@ -59,16 +59,16 @@ end module simpler
stmt_fcn (w) = sin (w)
call x (y ())
x = 10 ! { dg-error "is not a variable" }
- y = 20 ! { dg-error "is not a VALUE" }
- foo_er = 8 ! { dg-error "is not a VALUE" }
- ext1 = 99 ! { dg-error "is not a VALUE" }
- ext2 = 99 ! { dg-error "is not a VALUE" }
+ y = 20 ! { dg-error "is not a variable" }
+ foo_er = 8 ! { dg-error "is not a variable" }
+ ext1 = 99 ! { dg-error "is not a variable" }
+ ext2 = 99 ! { dg-error "is not a variable" }
stmt_fcn = 1.0 ! { dg-error "is not a variable" }
w = stmt_fcn (1.0)
contains
subroutine x (i)
integer i
- y = i ! { dg-error "is not a VALUE" }
+ y = i ! { dg-error "is not a variable" }
end subroutine x
function y ()
integer y
Index: testsuite/gfortran.dg/proc_assign_2.f90
===================================================================
--- testsuite/gfortran.dg/proc_assign_2.f90 (revision 133396)
+++ testsuite/gfortran.dg/proc_assign_2.f90 (working copy)
@@ -14,7 +14,7 @@ CONTAINS
END FUNCTION
LOGICAL FUNCTION f2()
- f1 = .FALSE. ! { dg-error "not a VALUE" }
+ f1 = .FALSE. ! { dg-error "is not a variable" }
END FUNCTION
END FUNCTION
END MODULE
Index: testsuite/gfortran.dg/procedure_lvalue.f90
===================================================================
--- testsuite/gfortran.dg/procedure_lvalue.f90 (revision 133396)
+++ testsuite/gfortran.dg/procedure_lvalue.f90 (working copy)
@@ -14,7 +14,7 @@ end module t
subroutine r
use t
- b = 1. ! { dg-error "is not a VALUE" }
+ b = 1. ! { dg-error "is not a variable" }
y = a(1.)
end subroutine r