summaryrefslogtreecommitdiff
path: root/gcc/fortran/match.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/match.c')
-rw-r--r--gcc/fortran/match.c169
1 files changed, 69 insertions, 100 deletions
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3e969e78ca2..24e292bd4d6 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -29,9 +29,8 @@ along with GCC; see the file COPYING3. If not see
int gfc_matching_procptr_assignment = 0;
bool gfc_matching_prefix = false;
-/* Used for SELECT TYPE statements. */
-gfc_symbol *type_selector;
-gfc_symtree *select_type_tmp;
+/* Stack of SELECT TYPE statements. */
+gfc_select_type_stack *select_type_stack = NULL;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
@@ -2389,58 +2388,6 @@ char_selector:
}
-/* Used in gfc_match_allocate to check that a allocation-object and
- a source-expr are conformable. This does not catch all possible
- cases; in particular a runtime checking is needed. */
-
-static gfc_try
-conformable_arrays (gfc_expr *e1, gfc_expr *e2)
-{
- /* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
- {
- gfc_error ("Source-expr at %L must be scalar or have the "
- "same rank as the allocate-object at %L",
- &e1->where, &e2->where);
- return FAILURE;
- }
-
- if (e1->shape)
- {
- int i;
- mpz_t s;
-
- mpz_init (s);
-
- for (i = 0; i < e1->rank; i++)
- {
- if (e2->ref->u.ar.end[i])
- {
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
- mpz_add_ui (s, s, 1);
- }
- else
- {
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
- }
-
- if (mpz_cmp (e1->shape[i], s) != 0)
- {
- gfc_error ("Source-expr at %L and allocate-object at %L must "
- "have the same shape", &e1->where, &e2->where);
- mpz_clear (s);
- return FAILURE;
- }
- }
-
- mpz_clear (s);
- }
-
- return SUCCESS;
-}
-
-
/* Match an ALLOCATE statement. */
match
@@ -2621,7 +2568,7 @@ alloc_opt_list:
goto cleanup;
}
- /* The next 3 conditionals check C631. */
+ /* The next 2 conditionals check C631. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
@@ -2636,28 +2583,6 @@ alloc_opt_list:
goto cleanup;
}
- gfc_resolve_expr (tmp);
-
- if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "source-expr at %L", &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C633. */
- if (tmp->ts.kind != head->expr->ts.kind)
- {
- gfc_error ("The allocate-object at %L and the source-expr at %L "
- "shall have the same kind type parameter",
- &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C632 and restriction following Note 6.18. */
- if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
- goto cleanup;
-
source = tmp;
saw_source = true;
@@ -3751,7 +3676,10 @@ gfc_match_equivalence (void)
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
+ {
+ gfc_error ("Expecting a comma in EQUIVALENCE at %C");
+ goto cleanup;
+ }
}
return MATCH_YES;
@@ -4021,46 +3949,90 @@ gfc_match_select (void)
}
+/* Push the current selector onto the SELECT TYPE stack. */
+
+static void
+select_type_push (gfc_symbol *sel)
+{
+ gfc_select_type_stack *top = gfc_get_select_type_stack ();
+ top->selector = sel;
+ top->tmp = NULL;
+ top->prev = select_type_stack;
+
+ select_type_stack = top;
+}
+
+
+/* Set the temporary for the current SELECT TYPE selector. */
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+
+ sprintf (name, "tmp$%s", ts->u.derived->name);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+ gfc_add_type (tmp->n.sym, ts, NULL);
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_pointer (&tmp->n.sym->attr, NULL);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+
+ select_type_stack->tmp = tmp;
+}
+
+
/* Match a SELECT TYPE statement. */
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;
+ expr1->symtree->n.sym->attr.class_ok = 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 +4040,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;
+ select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
}
@@ -4155,7 +4129,6 @@ gfc_match_type_is (void)
{
gfc_case *c = NULL;
match m;
- char name[GFC_MAX_SYMBOL_LEN];
if (gfc_current_state () != COMP_SELECT_TYPE)
{
@@ -4187,11 +4160,7 @@ gfc_match_type_is (void)
new_st.ext.case_list = c;
/* Create temporary variable. */
- sprintf (name, "tmp$%s", c->ts.u.derived->name);
- gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false);
- select_type_tmp->n.sym->ts = c->ts;
- select_type_tmp->n.sym->attr.referenced = 1;
- select_type_tmp->n.sym->attr.pointer = 1;
+ select_type_set_tmp (&c->ts);
return MATCH_YES;
View Lorry Controller Status