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;
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);
}
if (lvalue->symtree->n.sym->attr.proc_pointer
- || is_proc_ptr_comp (lvalue, NULL))
+ || gfc_is_proc_ptr_comp (lvalue, NULL))
gfc_matching_procptr_assignment = 1;
m = gfc_match (" %e%t", &rvalue);
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, *errmsg, *tmp;
+ gfc_expr *stat, *errmsg, *tmp, *source;
+ gfc_typespec ts;
match m;
- bool saw_stat, saw_errmsg;
+ locus old_locus;
+ bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
head = tail = NULL;
- stat = errmsg = tmp = NULL;
- saw_stat = saw_errmsg = false;
+ 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)
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. */
- if (!(tail->expr->ref
+ b1 = !(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))
+ || 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 (m == MATCH_YES)
{
+ /* Enforce C630. */
if (saw_stat)
{
gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
- gfc_free_expr (tmp);
goto cleanup;
}
goto cleanup;
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ 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);
- gfc_free_expr (tmp);
goto cleanup;
}
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 () == ')')
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;
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;
}
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;
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;
}
"at %C");
return MATCH_ERROR;
}
- new_st.expr = base;
+ new_st.expr1 = base;
return MATCH_YES;
}
{
/* ...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;
OSDN Git Service
