Commit 93d76687 by Janus Weil

expr.c (gfc_check_pointer_assign): Do the correct type checking when CLASS variables are involved.

2009-10-07  Janus Weil  <janus@gcc.gnu.org>

	* expr.c (gfc_check_pointer_assign): Do the correct type checking when
	CLASS variables are involved.
	* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
	statements, and set up a local namespace for the SELECT TYPE block.
	* parse.h (gfc_build_block_ns): New prototype.
	* parse.c (parse_select_type_block): Return from local namespace to its
	parent after SELECT TYPE block.
	(gfc_build_block_ns): New function for setting up the local namespace
	for a BLOCK construct.
	(parse_block_construct): Use gfc_build_block_ns.
	* resolve.c (resolve_select_type): Insert assignment for the selector
	variable, in case an associate-name is given, and put the SELECT TYPE
	statement inside a BLOCK.
	(resolve_code): Call resolve_class_assign after checking the assignment.
	* symbol.c (gfc_find_sym_tree): Moved some code here from
	gfc_get_ha_sym_tree.
	(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.


2009-10-07  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/same_type_as_2.f03: Modified (was illegal).
	* gfortran.dg/select_type_1.f03: Modified error message.
	* gfortran.dg/select_type_5.f03: New test.

From-SVN: r152526
parent 0b9036f4
2009-10-07 Janus Weil <janus@gcc.gnu.org>
* expr.c (gfc_check_pointer_assign): Do the correct type checking when
CLASS variables are involved.
* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
statements, and set up a local namespace for the SELECT TYPE block.
* parse.h (gfc_build_block_ns): New prototype.
* parse.c (parse_select_type_block): Return from local namespace to its
parent after SELECT TYPE block.
(gfc_build_block_ns): New function for setting up the local namespace
for a BLOCK construct.
(parse_block_construct): Use gfc_build_block_ns.
* resolve.c (resolve_select_type): Insert assignment for the selector
variable, in case an associate-name is given, and put the SELECT TYPE
statement inside a BLOCK.
(resolve_code): Call resolve_class_assign after checking the assignment.
* symbol.c (gfc_find_sym_tree): Moved some code here from
gfc_get_ha_sym_tree.
(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.
2009-10-07 Paul Thomas <pault@gcc.gnu.org> 2009-10-07 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41613 PR fortran/41613
......
...@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) ...@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS; return SUCCESS;
} }
if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
&& !gfc_compare_types (&lvalue->ts, &rvalue->ts))
{ {
gfc_error ("Different types in pointer assignment at %L; attempted " gfc_error ("Different types in pointer assignment at %L; attempted "
"assignment of %s to %s", &lvalue->where, "assignment of %s to %s", &lvalue->where,
......
...@@ -4026,41 +4026,51 @@ gfc_match_select (void) ...@@ -4026,41 +4026,51 @@ gfc_match_select (void)
match match
gfc_match_select_type (void) gfc_match_select_type (void)
{ {
gfc_expr *expr; gfc_expr *expr1, *expr2 = NULL;
match m; match m;
char name[GFC_MAX_SYMBOL_LEN];
m = gfc_match_label (); m = gfc_match_label ();
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return m; return m;
m = gfc_match (" select type ( %e ", &expr); m = gfc_match (" select type ( ");
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
/* TODO: Implement ASSOCIATE. */ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
m = gfc_match (" => ");
m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES) if (m == MATCH_YES)
{ {
gfc_error ("Associate-name in SELECT TYPE statement at %C " expr1 = gfc_get_expr();
"is not yet supported"); expr1->expr_type = EXPR_VARIABLE;
return MATCH_ERROR; if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
return MATCH_ERROR;
expr1->symtree->n.sym->ts = expr2->ts;
expr1->symtree->n.sym->attr.referenced = 1;
}
else
{
m = gfc_match (" %e ", &expr1);
if (m != MATCH_YES)
return m;
} }
m = gfc_match (" )%t"); m = gfc_match (" )%t");
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
/* Check for F03:C811. /* Check for F03:C811. */
TODO: Change error message once ASSOCIATE is implemented. */ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL)
{ {
gfc_error ("Selector must be a named variable in SELECT TYPE statement " gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"at %C"); "use associate-name=>");
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Check for F03:C813. */ /* Check for F03:C813. */
if (expr->ts.type != BT_CLASS) if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
{ {
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
"at %C"); "at %C");
...@@ -4068,9 +4078,11 @@ gfc_match_select_type (void) ...@@ -4068,9 +4078,11 @@ gfc_match_select_type (void)
} }
new_st.op = EXEC_SELECT_TYPE; new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr; new_st.expr1 = expr1;
new_st.expr2 = expr2;
new_st.ext.ns = gfc_current_ns;
type_selector = expr->symtree->n.sym; type_selector = expr1->symtree->n.sym;
return MATCH_YES; return MATCH_YES;
} }
......
...@@ -2909,12 +2909,8 @@ parse_select_type_block (void) ...@@ -2909,12 +2909,8 @@ parse_select_type_block (void)
if (st == ST_NONE) if (st == ST_NONE)
unexpected_eof (); unexpected_eof ();
if (st == ST_END_SELECT) if (st == ST_END_SELECT)
{ /* Empty SELECT CASE is OK. */
/* Empty SELECT CASE is OK. */ goto done;
accept_statement (st);
pop_state ();
return;
}
if (st == ST_TYPE_IS || st == ST_CLASS_IS) if (st == ST_TYPE_IS || st == ST_CLASS_IS)
break; break;
...@@ -2959,8 +2955,10 @@ parse_select_type_block (void) ...@@ -2959,8 +2955,10 @@ parse_select_type_block (void)
} }
while (st != ST_END_SELECT); while (st != ST_END_SELECT);
done:
pop_state (); pop_state ();
accept_statement (st); accept_statement (st);
gfc_current_ns = gfc_current_ns->parent;
} }
...@@ -3033,18 +3031,13 @@ check_do_closure (void) ...@@ -3033,18 +3031,13 @@ check_do_closure (void)
static void parse_progunit (gfc_statement); static void parse_progunit (gfc_statement);
/* Parse a BLOCK construct. */ /* Set up the local namespace for a BLOCK construct. */
static void gfc_namespace*
parse_block_construct (void) gfc_build_block_ns (gfc_namespace *parent_ns)
{ {
gfc_namespace* parent_ns;
gfc_namespace* my_ns; gfc_namespace* my_ns;
gfc_state_data s;
gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
parent_ns = gfc_current_ns;
my_ns = gfc_get_namespace (parent_ns, 1); my_ns = gfc_get_namespace (parent_ns, 1);
my_ns->construct_entities = 1; my_ns->construct_entities = 1;
...@@ -3066,6 +3059,22 @@ parse_block_construct (void) ...@@ -3066,6 +3059,22 @@ parse_block_construct (void)
} }
my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive; my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
return my_ns;
}
/* Parse a BLOCK construct. */
static void
parse_block_construct (void)
{
gfc_namespace* my_ns;
gfc_state_data s;
gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
my_ns = gfc_build_block_ns (gfc_current_ns);
new_st.op = EXEC_BLOCK; new_st.op = EXEC_BLOCK;
new_st.ext.ns = my_ns; new_st.ext.ns = my_ns;
accept_statement (ST_BLOCK); accept_statement (ST_BLOCK);
...@@ -3075,7 +3084,7 @@ parse_block_construct (void) ...@@ -3075,7 +3084,7 @@ parse_block_construct (void)
parse_progunit (ST_NONE); parse_progunit (ST_NONE);
gfc_current_ns = parent_ns; gfc_current_ns = gfc_current_ns->parent;
pop_state (); pop_state ();
} }
......
...@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void); ...@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void); void gfc_free_enum_history (void);
extern bool gfc_matching_function; extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *); match gfc_match_prefix (gfc_typespec *);
gfc_namespace* gfc_build_block_ns (gfc_namespace *);
#endif /* GFC_PARSE_H */ #endif /* GFC_PARSE_H */
...@@ -6661,8 +6661,15 @@ resolve_select_type (gfc_code *code) ...@@ -6661,8 +6661,15 @@ resolve_select_type (gfc_code *code)
gfc_case *c, *default_case; gfc_case *c, *default_case;
gfc_symtree *st; gfc_symtree *st;
char name[GFC_MAX_SYMBOL_LEN]; char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns;
ns = code->ext.ns;
gfc_resolve (ns);
selector_type = code->expr1->ts.u.derived->components->ts.u.derived; if (code->expr2)
selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
/* Assume there is no DEFAULT case. */ /* Assume there is no DEFAULT case. */
default_case = NULL; default_case = NULL;
...@@ -6704,6 +6711,32 @@ resolve_select_type (gfc_code *code) ...@@ -6704,6 +6711,32 @@ resolve_select_type (gfc_code *code)
} }
} }
if (code->expr2)
{
/* Insert assignment for selector variable. */
new_st = gfc_get_code ();
new_st->op = EXEC_ASSIGN;
new_st->expr1 = gfc_copy_expr (code->expr1);
new_st->expr2 = gfc_copy_expr (code->expr2);
ns->code = new_st;
}
/* Put SELECT TYPE statement inside a BLOCK. */
new_st = gfc_get_code ();
new_st->op = code->op;
new_st->expr1 = code->expr1;
new_st->expr2 = code->expr2;
new_st->block = code->block;
if (!ns->code)
ns->code = new_st;
else
ns->code->next = new_st;
code->op = EXEC_BLOCK;
code->expr1 = code->expr2 = NULL;
code->block = NULL;
code = new_st;
/* Transform to EXEC_SELECT. */ /* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT; code->op = EXEC_SELECT;
gfc_add_component_ref (code->expr1, "$vindex"); gfc_add_component_ref (code->expr1, "$vindex");
...@@ -6723,7 +6756,7 @@ resolve_select_type (gfc_code *code) ...@@ -6723,7 +6756,7 @@ resolve_select_type (gfc_code *code)
continue; continue;
/* Assign temporary to selector. */ /* Assign temporary to selector. */
sprintf (name, "tmp$%s", c->ts.u.derived->name); sprintf (name, "tmp$%s", c->ts.u.derived->name);
st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name); st = gfc_find_symtree (ns->sym_root, name);
new_st = gfc_get_code (); new_st = gfc_get_code ();
new_st->op = EXEC_POINTER_ASSIGN; new_st->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st); new_st->expr1 = gfc_get_variable_expr (st);
...@@ -7669,9 +7702,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -7669,9 +7702,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE) if (t == FAILURE)
break; break;
if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code);
if (resolve_ordinary_assign (code, ns)) if (resolve_ordinary_assign (code, ns))
{ {
if (code->op == EXEC_COMPCALL) if (code->op == EXEC_COMPCALL)
...@@ -7680,6 +7710,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -7680,6 +7710,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
goto call; goto call;
} }
if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code);
break; break;
case EXEC_LABEL_ASSIGN: case EXEC_LABEL_ASSIGN:
...@@ -7700,11 +7733,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) ...@@ -7700,11 +7733,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE) if (t == FAILURE)
break; break;
gfc_check_pointer_assign (code->expr1, code->expr2);
if (code->expr1->ts.type == BT_CLASS) if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code); resolve_class_assign (code);
gfc_check_pointer_assign (code->expr1, code->expr2);
break; break;
case EXEC_ARITHMETIC_IF: case EXEC_ARITHMETIC_IF:
......
...@@ -2479,6 +2479,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, ...@@ -2479,6 +2479,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
st = gfc_find_symtree (ns->sym_root, name); st = gfc_find_symtree (ns->sym_root, name);
if (st != NULL) if (st != NULL)
{ {
/* Special case: If we're in a SELECT TYPE block,
replace the selector variable by a temporary. */
if (gfc_current_state () == COMP_SELECT_TYPE
&& st && st->n.sym == type_selector)
st = select_type_tmp;
*result = st; *result = st;
/* Ambiguous generic interfaces are permitted, as long /* Ambiguous generic interfaces are permitted, as long
as the specific interfaces are different. */ as the specific interfaces are different. */
...@@ -2645,12 +2651,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) ...@@ -2645,12 +2651,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
/* Special case: If we're in a SELECT TYPE block,
replace the selector variable by a temporary. */
if (gfc_current_state () == COMP_SELECT_TYPE
&& st && st->n.sym == type_selector)
st = select_type_tmp;
if (st != NULL) if (st != NULL)
{ {
save_symbol_data (st->n.sym); save_symbol_data (st->n.sym);
......
2009-10-07 Janus Weil <janus@gcc.gnu.org>
* gfortran.dg/same_type_as_2.f03: Modified (was illegal).
* gfortran.dg/select_type_1.f03: Modified error message.
* gfortran.dg/select_type_5.f03: New test.
2009-10-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> 2009-10-06 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/41612 PR libgfortran/41612
......
...@@ -8,12 +8,11 @@ ...@@ -8,12 +8,11 @@
integer :: i integer :: i
end type end type
type :: t2 type, extends(t1) :: t2
integer :: j integer :: j
end type end type
CLASS(t1), pointer :: c1 CLASS(t1), pointer :: c1,c2
CLASS(t2), pointer :: c2
TYPE(t1), target :: x1 TYPE(t1), target :: x1
TYPE(t2) ,target :: x2 TYPE(t2) ,target :: x2
......
...@@ -30,8 +30,8 @@ ...@@ -30,8 +30,8 @@
type is (t1) ! { dg-error "Unexpected TYPE IS statement" } type is (t1) ! { dg-error "Unexpected TYPE IS statement" }
select type (3.5) ! { dg-error "Selector must be a named variable" } select type (3.5) ! { dg-error "is not a named variable" }
select type (a%cp) ! { dg-error "Selector must be a named variable" } select type (a%cp) ! { dg-error "is not a named variable" }
select type (b) ! { dg-error "Selector shall be polymorphic" } select type (b) ! { dg-error "Selector shall be polymorphic" }
select type (a) select type (a)
......
! { dg-do run }
!
! SELECT TYPE with associate-name
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
type :: t1
integer :: i = -1
class(t1), pointer :: c
end type t1
type, extends(t1) :: t2
integer :: j = -1
end type t2
type(t2), target :: b
integer :: aa
b%c => b
aa = 5
select type (aa => b%c)
type is (t1)
aa%i = 1
type is (t2)
aa%j = 2
end select
print *,b%i,b%j
if (b%i /= -1) call abort()
if (b%j /= 2) call abort()
select type (aa => b%c)
type is (t1)
aa%i = 4
type is (t2)
aa%i = 3*aa%j
end select
print *,b%i,b%j
if (b%i /= 6) call abort()
if (b%j /= 2) call abort()
print *,aa
if (aa/=5) call abort()
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment