return (gfc_get_ha_sym_tree (buffer, matched_symbol))
? MATCH_ERROR : MATCH_YES;
- if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
+ if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
return MATCH_ERROR;
return MATCH_YES;
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)
gfc_set_sym_referenced (lvalue->symtree->n.sym);
new_st.op = EXEC_ASSIGN;
- new_st.expr = lvalue;
+ new_st.expr1 = lvalue;
new_st.expr2 = rvalue;
gfc_check_do_variable (lvalue->symtree);
goto cleanup;
}
- if (lvalue->symtree->n.sym->attr.proc_pointer)
+ if (lvalue->symtree->n.sym->attr.proc_pointer
+ || gfc_is_proc_ptr_comp (lvalue, NULL))
gfc_matching_procptr_assignment = 1;
m = gfc_match (" %e%t", &rvalue);
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.expr1 = lvalue;
new_st.expr2 = rvalue;
return MATCH_YES;
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
- "at %C") == FAILURE)
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
+ "statement at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr = expr;
- new_st.label = l1;
+ new_st.expr1 = expr;
+ new_st.label1 = l1;
new_st.label2 = l2;
new_st.label3 = l3;
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
"statement at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr = expr;
- new_st.label = l1;
+ new_st.expr1 = expr;
+ new_st.label1 = l1;
new_st.label2 = l2;
new_st.label3 = l3;
if (gfc_match (" then%t") == MATCH_YES)
{
new_st.op = EXEC_IF;
- new_st.expr = expr;
+ new_st.expr1 = expr;
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
*p->next = new_st;
p->next->loc = gfc_current_locus;
- p->expr = expr;
+ p->expr1 = expr;
p->op = EXEC_IF;
gfc_clear_new_st ();
done:
new_st.op = EXEC_IF;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
cleanup:
&& gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
goto cleanup;
- new_st.label = label;
+ new_st.label1 = label;
if (new_st.op == EXEC_DO_WHILE)
- new_st.expr = iter.end;
+ new_st.expr1 = iter.end;
else
{
new_st.ext.iterator = ip = gfc_get_iterator ();
}
new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
- new_st.expr = e;
+ new_st.expr1 = e;
new_st.ext.stop_code = stop_code;
return MATCH_YES;
expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label = label;
- new_st.expr = expr;
+ new_st.label1 = label;
+ new_st.expr1 = expr;
return MATCH_YES;
}
}
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
- new_st.label = label;
+ new_st.label1 = label;
return MATCH_YES;
}
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
- new_st.expr = expr;
+ new_st.expr1 = expr;
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
tail = tail->block;
}
- tail->label = label;
+ tail->label1 = label;
tail->op = EXEC_GOTO;
}
while (gfc_match_char (',') == MATCH_YES);
tail->next = gfc_get_code ();
tail->next->op = EXEC_GOTO;
- tail->next->label = label;
+ tail->next->label1 = label;
}
while (gfc_match_char (',') == MATCH_YES);
if (gfc_match (" %e%t", &expr) != MATCH_YES)
goto syntax;
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
+ "at %C") == FAILURE)
+ return MATCH_ERROR;
+
/* At this point, a computed GOTO has been fully matched and an
equivalent SELECT statement constructed. */
new_st.op = EXEC_SELECT;
- new_st.expr = NULL;
+ new_st.expr1 = NULL;
/* Hack: For a "real" SELECT, the expression is in expr. We put
it in expr2 so we can distinguish then and produce the correct
}
+/* Match a Fortran 2003 intrinsic-type-spec. This is a stripped
+ down version of gfc_match_type_spec() from decl.c. It only includes
+ the intrinsic types from the Fortran 2003 standard. Thus, neither
+ BYTE nor forms like REAL*4 are allowed. Additionally, the implicit_flag
+ is not needed, so it was removed. The handling of derived types has
+ been removed and no notion of the gfc_matching_function state
+ is needed. In short, this functions matches only standard conforming
+ intrinsic-type-spec (R403). */
+
+static match
+match_intrinsic_typespec (gfc_typespec *ts)
+{
+ match m;
+
+ gfc_clear_ts (ts);
+
+ if (gfc_match ("integer") == MATCH_YES)
+ {
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_default_integer_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("real") == MATCH_YES)
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_real_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("double precision") == MATCH_YES)
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_double_kind;
+ return MATCH_YES;
+ }
+
+ if (gfc_match ("complex") == MATCH_YES)
+ {
+ ts->type = BT_COMPLEX;
+ ts->kind = gfc_default_complex_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("character") == MATCH_YES)
+ {
+ ts->type = BT_CHARACTER;
+ goto char_selector;
+ }
+
+ if (gfc_match ("logical") == MATCH_YES)
+ {
+ ts->type = BT_LOGICAL;
+ ts->kind = gfc_default_logical_kind;
+ goto kind_selector;
+ }
+
+ /* If an intrinsic type is not matched, simply return MATCH_NO. */
+ return MATCH_NO;
+
+kind_selector:
+
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () == '*')
+ {
+ gfc_error ("Invalid type-spec at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_kind_spec (ts, false);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES; /* No kind specifier found. */
+
+ return m;
+
+char_selector:
+
+ m = gfc_match_char_spec (ts);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES; /* No kind specifier found. */
+
+ return m;
+}
+
+
+/* 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
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp, *source;
+ gfc_typespec ts;
match m;
+ locus old_locus;
+ bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = source = tmp = NULL;
+ saw_stat = saw_errmsg = saw_source = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
+ /* Match an optional intrinsic-type-spec. */
+ old_locus = gfc_current_locus;
+ m = match_intrinsic_typespec (&ts);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ else if (m == MATCH_NO)
+ ts.type = BT_UNKNOWN;
+ else
+ {
+ if (gfc_match (" :: ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
+ "ALLOCATE at %L", &old_locus) == FAILURE)
+ goto cleanup;
+ }
+ else
+ {
+ ts.type = BT_UNKNOWN;
+ gfc_current_locus = old_locus;
+ }
+ }
+
for (;;)
{
if (head == NULL)
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
- "PURE procedure");
+ gfc_error ("Bad allocate-object at %C for a PURE procedure");
goto cleanup;
}
+ /* The ALLOCATE statement had an optional typespec. Check the
+ constraints. */
+ if (ts.type != BT_UNKNOWN)
+ {
+ /* Enforce C626. */
+ if (ts.type != tail->expr->ts.type)
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "typespec", &tail->expr->where);
+ goto cleanup;
+ }
+
+ /* Enforce C627. */
+ if (ts.kind != tail->expr->ts.kind)
+ {
+ gfc_error ("Kind type parameter for entity at %L differs from "
+ "the kind type parameter of the typespec",
+ &tail->expr->where);
+ goto cleanup;
+ }
+ }
+
if (tail->expr->ts.type == BT_DERIVED)
- tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+ tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+
+ /* FIXME: disable the checking on derived types and arrays. */
+ b1 = !(tail->expr->ref
+ && (tail->expr->ref->type == REF_COMPONENT
+ || tail->expr->ref->type == REF_ARRAY));
+ b2 = tail->expr->symtree->n.sym
+ && !(tail->expr->symtree->n.sym->attr.allocatable
+ || tail->expr->symtree->n.sym->attr.pointer
+ || tail->expr->symtree->n.sym->attr.proc_pointer);
+ b3 = tail->expr->symtree->n.sym
+ && tail->expr->symtree->n.sym->ns
+ && tail->expr->symtree->n.sym->ns->proc_name
+ && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
+ || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
+ || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
+ if (b1 && b2 && !b3)
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
+ goto cleanup;
+ }
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+alloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
+ {
+ /* Enforce C630. */
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ /* Enforce C630. */
+ 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)
+ goto alloc_opt_list;
+ }
+
+ m = gfc_match (" source = %e", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ /* Enforce C630. */
+ if (saw_source)
+ {
+ gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+
+ /* The next 3 conditionals check C631. */
+ if (ts.type != BT_UNKNOWN)
+ {
+ gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
+ &tmp->where, &old_locus);
+ goto cleanup;
+ }
+
+ if (head->next)
+ {
+ gfc_error ("SOURCE tag at %L requires only a single entity in "
+ "the allocation-list", &tmp->where);
+ goto cleanup;
+ }
+
+ gfc_resolve_expr (tmp);
+
+ if (head->expr->ts.type != tmp->ts.type)
+ {
+ 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;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
}
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_ALLOCATE;
- new_st.expr = stat;
+ new_st.expr1 = stat;
+ new_st.expr2 = errmsg;
+ new_st.expr3 = source;
new_st.ext.alloc_list = head;
return MATCH_YES;
gfc_syntax_error (ST_ALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
+ gfc_free_expr (source);
gfc_free_expr (stat);
+ gfc_free_expr (tmp);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
}
tail->op = EXEC_POINTER_ASSIGN;
- tail->expr = p;
+ tail->expr1 = p;
tail->expr2 = e;
if (gfc_match (" )%t") == MATCH_YES)
cleanup:
gfc_free_statements (new_st.next);
+ new_st.next = NULL;
+ gfc_free_expr (new_st.expr1);
+ new_st.expr1 = NULL;
+ gfc_free_expr (new_st.expr2);
+ new_st.expr2 = NULL;
return MATCH_ERROR;
}
gfc_match_deallocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
match m;
+ bool saw_stat, saw_errmsg;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
- "for a PURE procedure");
+ gfc_error ("Illegal allocate-object at %C for a PURE procedure");
+ goto cleanup;
+ }
+
+ /* FIXME: disable the checking on derived types. */
+ if (!(tail->expr->ref
+ && (tail->expr->ref->type == REF_COMPONENT
+ || tail->expr->ref->type == REF_ARRAY))
+ && tail->expr->symtree->n.sym
+ && !(tail->expr->symtree->n.sym->attr.allocatable
+ || tail->expr->symtree->n.sym->attr.pointer
+ || tail->expr->symtree->n.sym->attr.proc_pointer))
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
goto cleanup;
}
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+dealloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
- }
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
+ }
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_DEALLOCATE;
- new_st.expr = stat;
+ new_st.expr1 = stat;
+ new_st.expr2 = errmsg;
new_st.ext.alloc_list = head;
return MATCH_YES;
gfc_syntax_error (ST_DEALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
goto cleanup;
}
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
+ "at %C") == FAILURE)
+ return MATCH_ERROR;
+
if (gfc_current_form == FORM_FREE)
{
/* The following are valid, so we can't require a blank after the
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
- new_st.expr = e;
+ new_st.expr1 = e;
+
+ return MATCH_YES;
+}
+
+
+/* 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, 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)
+ new_st.op = EXEC_COMPCALL;
+ else if (base->expr_type == EXPR_PPC)
+ new_st.op = EXEC_CALL_PPC;
+ else
+ {
+ gfc_error ("Expected type-bound procedure or procedure pointer component "
+ "at %C");
+ return MATCH_ERROR;
+ }
+ new_st.expr1 = base;
return MATCH_YES;
}
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))
{
/* ...create a symbol in this scope... */
if (sym->ns != gfc_current_ns
- && gfc_get_sym_tree (name, NULL, &st) == 1)
+ && gfc_get_sym_tree (name, NULL, &st, false) == 1)
return MATCH_ERROR;
if (sym != st->n.sym)
select_sym->ts.type = BT_INTEGER;
select_sym->ts.kind = gfc_default_integer_kind;
gfc_set_sym_referenced (select_sym);
- c->expr = gfc_get_expr ();
- c->expr->expr_type = EXPR_VARIABLE;
- c->expr->symtree = select_st;
- c->expr->ts = select_sym->ts;
- c->expr->where = gfc_current_locus;
+ c->expr1 = gfc_get_expr ();
+ c->expr1->expr_type = EXPR_VARIABLE;
+ c->expr1->symtree = select_st;
+ c->expr1->ts = select_sym->ts;
+ c->expr1->where = gfc_current_locus;
i = 0;
for (a = arglist; a; a = a->next)
c->next = gfc_get_code ();
c->next->op = EXEC_GOTO;
- c->next->label = a->label;
+ c->next->label1 = a->label;
}
}
gfc_error_check ();
}
- if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length '%s' in namelist '%s' at "
"%C is not allowed", sym->name, group_name->name);
sym->value = expr;
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
+ "Statement function at %C") == FAILURE)
+ return MATCH_ERROR;
+
return MATCH_YES;
undo_error:
return m;
new_st.op = EXEC_SELECT;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
}
c = gfc_get_code ();
c->op = EXEC_WHERE;
- c->expr = expr;
+ c->expr1 = expr;
c->next = gfc_get_code ();
*c->next = new_st;
{
*st = ST_WHERE_BLOCK;
new_st.op = EXEC_WHERE;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
}
c = gfc_get_code ();
c->op = EXEC_WHERE;
- c->expr = expr;
+ c->expr1 = expr;
c->next = gfc_get_code ();
*c->next = new_st;
}
new_st.op = EXEC_WHERE;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
syntax:
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
{
*st = ST_FORALL_BLOCK;
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
return MATCH_YES;
}
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
new_st.block->op = EXEC_FORALL;