/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
- Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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. */
match ("cycle", gfc_match_cycle, ST_CYCLE)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
+ match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
match ("wait", gfc_match_wait, ST_WAIT)
+ match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
+ match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+ match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
}
+/* Match a CRITICAL statement. */
+match
+gfc_match_critical (void)
+{
+ gfc_st_label *label = NULL;
+
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" critical") != MATCH_YES)
+ return MATCH_NO;
+
+ if (gfc_match_st_label (&label) == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_syntax_error (ST_CRITICAL);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Nested CRITICAL block at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_CRITICAL;
+
+ if (label != NULL
+ && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
/* Match a BLOCK statement. */
match
break;
else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
+ else if (p->state == COMP_CRITICAL)
+ {
+ gfc_error("%s statement at %C leaves CRITICAL construct",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
if (p == NULL)
{
}
-/* Match a number or character constant after a STOP or PAUSE statement. */
+/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
static match
gfc_match_stopcode (gfc_statement st)
goto cleanup;
}
- new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
+ if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement STOP at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
+ switch (st)
+ {
+ case ST_STOP:
+ new_st.op = EXEC_STOP;
+ break;
+ case ST_ERROR_STOP:
+ new_st.op = EXEC_ERROR_STOP;
+ break;
+ case ST_PAUSE:
+ new_st.op = EXEC_PAUSE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
new_st.expr1 = e;
new_st.ext.stop_code = stop_code;
}
+/* Match the ERROR STOP statement. */
+
+match
+gfc_match_error_stop (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ return gfc_match_stopcode (ST_ERROR_STOP);
+}
+
+
+/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
+ SYNC ALL [(sync-stat-list)]
+ SYNC MEMORY [(sync-stat-list)]
+ SYNC IMAGES (image-set [, sync-stat-list] )
+ with sync-stat is int-expr or *. */
+
+static match
+sync_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *imageset, *stat, *errmsg;
+ bool saw_stat, saw_errmsg;
+
+ tmp = imageset = stat = errmsg = NULL;
+ saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement SYNC at %C in PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ if (st == ST_SYNC_IMAGES)
+ goto syntax;
+ goto done;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (st == ST_SYNC_IMAGES)
+ {
+ /* Denote '*' as imageset == NULL. */
+ m = gfc_match_char ('*');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ if (gfc_match ("%e", &imageset) != MATCH_YES)
+ goto syntax;
+ }
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
+
+ goto syntax;
+ }
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
+ {
+ case ST_SYNC_ALL:
+ new_st.op = EXEC_SYNC_ALL;
+ break;
+ case ST_SYNC_IMAGES:
+ new_st.op = EXEC_SYNC_IMAGES;
+ break;
+ case ST_SYNC_MEMORY:
+ new_st.op = EXEC_SYNC_MEMORY;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ new_st.expr1 = imageset;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ gfc_free_expr (tmp);
+ gfc_free_expr (imageset);
+ gfc_free_expr (stat);
+ gfc_free_expr (errmsg);
+
+ return MATCH_ERROR;
+}
+
+
+/* Match SYNC ALL statement. */
+
+match
+gfc_match_sync_all (void)
+{
+ return sync_statement (ST_SYNC_ALL);
+}
+
+
+/* Match SYNC IMAGES statement. */
+
+match
+gfc_match_sync_images (void)
+{
+ return sync_statement (ST_SYNC_IMAGES);
+}
+
+
+/* Match SYNC MEMORY statement. */
+
+match
+gfc_match_sync_memory (void)
+{
+ return sync_statement (ST_SYNC_MEMORY);
+}
+
+
/* Match a CONTINUE statement. */
match
}
-/* 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
goto cleanup;
}
+ if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
+ {
+ gfc_error ("Shape specification for allocatable scalar at %C");
+ goto cleanup;
+ }
+
if (gfc_match_char (',') != MATCH_YES)
break;
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",
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;
gfc_compile_state s;
e = NULL;
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement RETURN at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto done;
static match
match_typebound_call (gfc_symtree* varst)
{
- gfc_symbol* var;
gfc_expr* base;
match m;
- var = varst->n.sym;
-
base = gfc_get_expr ();
base->expr_type = EXPR_VARIABLE;
base->symtree = varst;
/* If this is a variable of derived-type, it probably starts a type-bound
procedure call. */
- if (sym->attr.flavor != FL_PROCEDURE
+ if ((sym->attr.flavor != FL_PROCEDURE
+ || gfc_is_function_return_value (sym, gfc_current_ns))
&& (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
return match_typebound_call (st);
/* Deal with an optional array specification after the
symbol name. */
- m = gfc_match_array_spec (&as);
+ m = gfc_match_array_spec (&as, true, true);
if (m == MATCH_ERROR)
goto cleanup;
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;
}
+/* 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;
+
+ if (!gfc_type_is_extensible (ts->u.derived))
+ return;
+
+ if (ts->type == BT_CLASS)
+ sprintf (name, "tmp$class$%s", ts->u.derived->name);
+ else
+ sprintf (name, "tmp$type$%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);
+ if (ts->type == BT_CLASS)
+ {
+ gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+ &tmp->n.sym->as);
+ tmp->n.sym->attr.class_ok = 1;
+ }
+
+ 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");
}
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;
}
{
gfc_case *c = NULL;
match m;
- char name[GFC_MAX_SYMBOL_LEN];
if (gfc_current_state () != COMP_SELECT_TYPE)
{
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;
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.case_list = c;
-
- gfc_error_now ("CLASS IS specification at %C is not yet supported");
+
+ /* Create temporary variable. */
+ select_type_set_tmp (&c->ts);
return MATCH_YES;
OSDN Git Service
