OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/44044 ([OOP] SELECT TYPE with class-valued function)

Browse Source 
2010-05-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
	(resolve_fl_variable_derived): ... this place.
	(resolve_symbol): Make sure function symbols (and their result
	variables) are not resolved twice.


2010-05-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* gfortran.dg/class_20.f03: New.

From-SVN: r159476
This commit is contained in:
Janus Weil 2010-05-17 10:25:06 +02:00
parent ff71b48db0
commit 233961db33
4 changed files with 80 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2010-05-17 Janus Weil <janus@gcc.gnu.org>
PR fortran/44044
* resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
(resolve_fl_variable_derived): ... this place.
(resolve_symbol): Make sure function symbols (and their result
variables) are not resolved twice.
2010-05-16 Daniel Franke <franke.daniel@gmail.com>
PR fortran/35779

48
gcc/fortran/resolve.c
View File

@ -9143,6 +9143,29 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
}
/* Constraints on polymorphic variables. */
if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
{
/* F03:C502. */
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
sym->ts.u.derived->components->ts.u.derived->name,
sym->name, &sym->declared_at);
return FAILURE;
}
/* F03:C509. */
/* Assume that use associated symbols were checked in the module ns. */
if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
}
@ -9194,27 +9217,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
&sym->declared_at) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CLASS)
{
/* C502. */
if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
{
gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
sym->ts.u.derived->components->ts.u.derived->name,
sym->name, &sym->declared_at);
return FAILURE;
}
/* C509. */
/* Assume that use associated symbols were checked in the module ns. */
if (!sym->attr.class_ok && !sym->attr.use_assoc)
{
gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
"or pointer", sym->name, &sym->declared_at);
return FAILURE;
}
}
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
@ -11130,6 +11132,10 @@ resolve_symbol (gfc_symbol *sym)
gfc_namespace *ns;
gfc_component *c;
/* Avoid double resolution of function result symbols. */
if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
return;
if (sym->attr.flavor == FL_UNKNOWN)
{

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-05-17 Janus Weil <janus@gcc.gnu.org>
PR fortran/44044
* gfortran.dg/class_20.f03: New.
2010-05-17 Christian Borntraeger <borntraeger@de.ibm.com>
PR 44078

40
gcc/testsuite/gfortran.dg/class_20.f03 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do compile }
!
! PR 44044: [OOP] SELECT TYPE with class-valued function
! comment #1
!
! Note: All three error messages are being checked for double occurrence,
! using the trick from PR 30612.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
type :: t
end type
type :: s
sequence
end type
contains
function fun() ! { dg-bogus "must be dummy, allocatable or pointer.*must be dummy, allocatable or pointer" }
class(t) :: fun
end function
function fun2() ! { dg-bogus "cannot have a deferred shape.*cannot have a deferred shape" }
integer,dimension(:) :: fun2
end function
function fun3() result(res) ! { dg-bogus "is not extensible.*is not extensible" }
class(s),pointer :: res
end function
end
! { dg-error "must be dummy, allocatable or pointer" "" { target *-*-* } 23 }
! { dg-error "cannot have a deferred shape" "" { target *-*-* } 27 }
! { dg-error "is not extensible" "" { target *-*-* } 31 }