aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog20
-rw-r--r--gcc/fortran/expr.c3
-rw-r--r--gcc/fortran/match.c42
-rw-r--r--gcc/fortran/parse.c39
-rw-r--r--gcc/fortran/parse.h1
-rw-r--r--gcc/fortran/resolve.c47
-rw-r--r--gcc/fortran/symbol.c12
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/same_type_as_2.f035
-rw-r--r--gcc/testsuite/gfortran.dg/select_type_1.f034
-rw-r--r--gcc/testsuite/gfortran.dg/select_type_5.f0347
11 files changed, 176 insertions, 50 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f833c20..7b4ecc6 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,23 @@
+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>
PR fortran/41613
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 32aa682..cbd3172 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return SUCCESS;
}
- if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
- && !gfc_compare_types (&lvalue->ts, &rvalue->ts))
+ if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
"assignment of %s to %s", &lvalue->where,
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3e969e7..d2c3ef0 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4026,41 +4026,51 @@ gfc_match_select (void)
match
gfc_match_select_type (void)
{
- gfc_expr *expr;
+ gfc_expr *expr1, *expr2 = NULL;
match m;
+ char name[GFC_MAX_SYMBOL_LEN];
m = gfc_match_label ();
if (m == MATCH_ERROR)
return m;
- m = gfc_match (" select type ( %e ", &expr);
+ m = gfc_match (" select type ( ");
if (m != MATCH_YES)
return m;
- /* TODO: Implement ASSOCIATE. */
- m = gfc_match (" => ");
+ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+ m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
- gfc_error ("Associate-name in SELECT TYPE statement at %C "
- "is not yet supported");
- return MATCH_ERROR;
+ expr1 = gfc_get_expr();
+ 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;
+ expr1->symtree->n.sym->attr.referenced = 1;
+ }
+ else
+ {
+ m = gfc_match (" %e ", &expr1);
+ if (m != MATCH_YES)
+ return m;
}
m = gfc_match (" )%t");
if (m != MATCH_YES)
return m;
- /* Check for F03:C811.
- TODO: Change error message once ASSOCIATE is implemented. */
- if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL)
+ /* Check for F03:C811. */
+ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
{
- gfc_error ("Selector must be a named variable in SELECT TYPE statement "
- "at %C");
+ gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+ "use associate-name=>");
return MATCH_ERROR;
}
/* 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 "
"at %C");
@@ -4068,9 +4078,11 @@ gfc_match_select_type (void)
}
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;
}
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 13199c9..770c7ef 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2909,12 +2909,8 @@ parse_select_type_block (void)
if (st == ST_NONE)
unexpected_eof ();
if (st == ST_END_SELECT)
- {
- /* Empty SELECT CASE is OK. */
- accept_statement (st);
- pop_state ();
- return;
- }
+ /* Empty SELECT CASE is OK. */
+ goto done;
if (st == ST_TYPE_IS || st == ST_CLASS_IS)
break;
@@ -2959,8 +2955,10 @@ parse_select_type_block (void)
}
while (st != ST_END_SELECT);
+done:
pop_state ();
accept_statement (st);
+ gfc_current_ns = gfc_current_ns->parent;
}
@@ -3033,18 +3031,13 @@ check_do_closure (void)
static void parse_progunit (gfc_statement);
-/* Parse a BLOCK construct. */
+/* Set up the local namespace for a BLOCK construct. */
-static void
-parse_block_construct (void)
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
{
- gfc_namespace* parent_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->construct_entities = 1;
@@ -3066,6 +3059,22 @@ parse_block_construct (void)
}
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.ext.ns = my_ns;
accept_statement (ST_BLOCK);
@@ -3075,7 +3084,7 @@ parse_block_construct (void)
parse_progunit (ST_NONE);
- gfc_current_ns = parent_ns;
+ gfc_current_ns = gfc_current_ns->parent;
pop_state ();
}
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 2b92661..e0a2969 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);
extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
#endif /* GFC_PARSE_H */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8acd580..4092891 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6661,8 +6661,15 @@ resolve_select_type (gfc_code *code)
gfc_case *c, *default_case;
gfc_symtree *st;
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. */
default_case = NULL;
@@ -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. */
code->op = EXEC_SELECT;
gfc_add_component_ref (code->expr1, "$vindex");
@@ -6723,7 +6756,7 @@ resolve_select_type (gfc_code *code)
continue;
/* Assign temporary to selector. */
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->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st);
@@ -7669,9 +7702,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
- if (code->expr1->ts.type == BT_CLASS)
- resolve_class_assign (code);
-
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
@@ -7680,6 +7710,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
goto call;
}
+ if (code->expr1->ts.type == BT_CLASS)
+ resolve_class_assign (code);
+
break;
case EXEC_LABEL_ASSIGN:
@@ -7700,11 +7733,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
+ gfc_check_pointer_assign (code->expr1, code->expr2);
+
if (code->expr1->ts.type == BT_CLASS)
resolve_class_assign (code);
- gfc_check_pointer_assign (code->expr1, code->expr2);
-
break;
case EXEC_ARITHMETIC_IF:
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 8cd18db..befa90b 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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);
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;
/* Ambiguous generic interfaces are permitted, as long
as the specific interfaces are different. */
@@ -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);
- /* 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)
{
save_symbol_data (st->n.sym);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aa3886c..f67f671 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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>
PR libgfortran/41612
diff --git a/gcc/testsuite/gfortran.dg/same_type_as_2.f03 b/gcc/testsuite/gfortran.dg/same_type_as_2.f03
index 9a2110d..6fd0311 100644
--- a/gcc/testsuite/gfortran.dg/same_type_as_2.f03
+++ b/gcc/testsuite/gfortran.dg/same_type_as_2.f03
@@ -8,12 +8,11 @@
integer :: i
end type
- type :: t2
+ type, extends(t1) :: t2
integer :: j
end type
- CLASS(t1), pointer :: c1
- CLASS(t2), pointer :: c2
+ CLASS(t1), pointer :: c1,c2
TYPE(t1), target :: x1
TYPE(t2) ,target :: x2
diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03
index e764ec9..6a7db2e 100644
--- a/gcc/testsuite/gfortran.dg/select_type_1.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_1.f03
@@ -30,8 +30,8 @@
type is (t1) ! { dg-error "Unexpected TYPE IS statement" }
- select type (3.5) ! { dg-error "Selector must be a named variable" }
- select type (a%cp) ! { 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 "is not a named variable" }
select type (b) ! { dg-error "Selector shall be polymorphic" }
select type (a)
diff --git a/gcc/testsuite/gfortran.dg/select_type_5.f03 b/gcc/testsuite/gfortran.dg/select_type_5.f03
new file mode 100644
index 0000000..ec9d3cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_5.f03
@@ -0,0 +1,47 @@
+! { 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
generated by cgit v1.1 at 2024-11-03 10:54:34 +0000