#include "parse.h"
int gfc_matching_procptr_assignment = 0;
+bool gfc_matching_prefix = false;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
}
default:
+
+ /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
+ expect an upper case character here! */
+ gcc_assert (TOLOWER (c) == c);
+
if (c == gfc_next_ascii_char ())
goto loop;
break;
return MATCH_NO;
}
- if (lvalue->symtree->n.sym->attr.is_protected
- && lvalue->symtree->n.sym->attr.use_assoc)
- {
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- gfc_error ("Setting value of PROTECTED variable at %C");
- return MATCH_ERROR;
- }
-
rvalue = NULL;
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
if (m != MATCH_YES)
goto cleanup;
- if (lvalue->symtree->n.sym->attr.is_protected
- && lvalue->symtree->n.sym->attr.use_assoc)
- {
- gfc_error ("Assigning to a PROTECTED pointer at %C");
- m = MATCH_ERROR;
- goto cleanup;
- }
-
new_st.op = EXEC_POINTER_ASSIGN;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
}
+/* Match the call of a type-bound procedure, if CALL%var has already been
+ matched and var found to be a derived-type variable. */
+
+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;
+ base->where = gfc_current_locus;
+ gfc_set_sym_referenced (varst->n.sym);
+
+ m = gfc_match_varspec (base, 0, true);
+ if (m == MATCH_NO)
+ gfc_error ("Expected component reference at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after CALL at %C");
+ return MATCH_ERROR;
+ }
+
+ if (base->expr_type != EXPR_COMPCALL)
+ {
+ gfc_error ("Expected type-bound procedure reference at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_COMPCALL;
+ new_st.expr = base;
+
+ return MATCH_YES;
+}
+
+
/* Match a CALL statement. The tricky part here are possible
alternate return specifiers. We handle these by having all
"subroutines" actually return an integer via a register that gives
sym = st->n.sym;
- /* If it does not seem to be callable... */
+ /* If this is a variable of derived-type, it probably starts a type-bound
+ procedure call. */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
+ return match_typebound_call (st);
+
+ /* If it does not seem to be callable (include functions so that the
+ right association is made. They are thrown out in resolution.)
+ ... */
if (!sym->attr.generic
- && !sym->attr.subroutine)
+ && !sym->attr.subroutine
+ && !sym->attr.function)
{
if (!(sym->attr.external && !sym->attr.referenced))
{
static match
match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
- gfc_forall_iterator *head, *tail, *new;
+ gfc_forall_iterator *head, *tail, *new_iter;
gfc_expr *msk;
match m;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
- head = tail = new;
+ head = tail = new_iter;
for (;;)
{
if (gfc_match_char (',') != MATCH_YES)
break;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
{
- tail->next = new;
- tail = new;
+ tail->next = new_iter;
+ tail = new_iter;
continue;
}