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-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* match.c (gfc_match_select_type): Move error message to
	resolve_select_type.
	* resolve.c (resolve_select_type): Error message moved here from
	gfc_match_select_type. Correctly set type of temporary.


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

	PR fortran/44044
	* gfortran.dg/class_7.f03: Modified.
	* gfortran.dg/select_type_1.f03: Modified.
	* gfortran.dg/select_type_12.f03: New.

From-SVN: r159217
This commit is contained in:
Janus Weil 2010-05-10 14:54:25 +02:00
parent 571943de9a
commit f5dbb57cce
7 changed files with 87 additions and 12 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-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/44044
* match.c (gfc_match_select_type): Move error message to
resolve_select_type.
* resolve.c (resolve_select_type): Error message moved here from
gfc_match_select_type. Correctly set type of temporary.
2010-05-10 Richard Guenther <rguenther@suse.de>
* trans-decl.c (gfc_build_library_function_decl): Split out

13
gcc/fortran/match.c
View File

@ -4314,7 +4314,10 @@ gfc_match_select_type (void)
expr1->expr_type = EXPR_VARIABLE;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
return MATCH_ERROR;
expr1->symtree->n.sym->ts = expr2->ts;
if (expr2->ts.type == BT_UNKNOWN)
expr1->symtree->n.sym->attr.untyped = 1;
else
expr1->symtree->n.sym->ts = expr2->ts;
expr1->symtree->n.sym->attr.referenced = 1;
expr1->symtree->n.sym->attr.class_ok = 1;
}
@ -4337,14 +4340,6 @@ gfc_match_select_type (void)
return MATCH_ERROR;
}
/* Check for F03:C813. */
if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
{
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
"at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;

15
gcc/fortran/resolve.c
View File

@ -7078,8 +7078,21 @@ resolve_select_type (gfc_code *code)
ns = code->ext.ns;
gfc_resolve (ns);
/* Check for F03:C813. */
if (code->expr1->ts.type != BT_CLASS
&& !(code->expr2 && code->expr2->ts.type == BT_CLASS))
{
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
"at %L", &code->loc);
return;
}
if (code->expr2)
selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
}
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2010-05-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/44044
* gfortran.dg/class_7.f03: Modified.
* gfortran.dg/select_type_1.f03: Modified.
* gfortran.dg/select_type_12.f03: New.
2010-05-10 Richard Guenther <rguenther@suse.de>
PR tree-optimization/44050

4
gcc/testsuite/gfortran.dg/class_7.f03
View File

@ -16,6 +16,6 @@
class(t1), pointer :: c ! { dg-error "before it is defined" }
select type (c) ! { dg-error "shall be polymorphic" }
type is (t1) ! { dg-error "Unexpected" }
end select ! { dg-error "Expecting END PROGRAM" }
type is (t0)
end select
end

1
gcc/testsuite/gfortran.dg/select_type_1.f03
View File

@ -33,6 +33,7 @@
select type (3.5) ! { dg-error "is not a named variable" }
select type (a%cp) ! { dg-error "is not a named variable" }
select type (b) ! { dg-error "Selector shall be polymorphic" }
end select
select type (a)
print *,"hello world!" ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" }

51
gcc/testsuite/gfortran.dg/select_type_12.f03 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do compile }
!
! PR 44044: [OOP] SELECT TYPE with class-valued function
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
implicit none
type :: t1
integer :: i
end type
type, extends(t1) :: t2
end type
type(t1),target :: x1
type(t2),target :: x2
select type ( y => fun(1) )
type is (t1)
print *,"t1"
type is (t2)
print *,"t2"
class default
print *,"default"
end select
select type ( y => fun(-1) )
type is (t1)
print *,"t1"
type is (t2)
print *,"t2"
class default
print *,"default"
end select
contains
function fun(i)
class(t1),pointer :: fun
integer :: i
if (i>0) then
fun => x1
else if (i<0) then
fun => x2
else
fun => NULL()
end if
end function
end