/* 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;
+/* 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. */
const char *
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;
}
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);
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;
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;
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
+gfc_match_block (void)
+{
+ match m;
+
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" block") != MATCH_YES)
+ return MATCH_NO;
+
+ /* For this to be a correct BLOCK statement, the line must end now. */
+ m = gfc_match_eos ();
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ return MATCH_NO;
+
+ return MATCH_YES;
+}
+
+
/* Match a DO 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
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. */
}
-/* Match an ALLOCATE statement. */
+/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
+ an accessible derived type. */
-match
-gfc_match_allocate (void)
+static match
+match_derived_type_spec (gfc_typespec *ts)
{
- gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp;
- match m;
- bool saw_stat, saw_errmsg;
-
- head = tail = NULL;
- stat = errmsg = tmp = NULL;
- saw_stat = saw_errmsg = false;
+ locus old_locus;
+ gfc_symbol *derived;
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
+ old_locus = gfc_current_locus;
- for (;;)
+ if (gfc_match_symbol (&derived, 1) == MATCH_YES)
{
- if (head == NULL)
- head = tail = gfc_get_alloc ();
+ if (derived->attr.flavor == FL_DERIVED)
+ {
+ ts->type = BT_DERIVED;
+ ts->u.derived = derived;
+ return MATCH_YES;
+ }
else
{
- tail->next = gfc_get_alloc ();
- tail = tail->next;
+ /* Enforce F03:C476. */
+ gfc_error ("'%s' at %L is not an accessible derived type",
+ derived->name, &gfc_current_locus);
+ return MATCH_ERROR;
}
+ }
- m = gfc_match_variable (&tail->expr, 0);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
+ gfc_current_locus = old_locus;
+ return MATCH_NO;
+}
- if (gfc_check_do_variable (tail->expr->symtree))
- goto cleanup;
- if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
- {
- gfc_error ("Bad allocate-object at %C for a PURE procedure");
- goto cleanup;
- }
+/* Match a Fortran 2003 type-spec (F03:R401). This is similar to
+ gfc_match_decl_type_spec() from decl.c, with the following exceptions:
+ 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. Derived types are
+ identified by their name alone. */
- if (tail->expr->ts.type == BT_DERIVED)
- tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+static match
+match_type_spec (gfc_typespec *ts)
+{
+ match m;
+ locus old_locus;
- /* FIXME: disable the checking on derived types and arrays. */
- 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_clear_ts (ts);
+ old_locus = gfc_current_locus;
+
+ 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;
+ }
+
+ m = match_derived_type_spec (ts);
+ if (m == MATCH_YES)
+ {
+ old_locus = gfc_current_locus;
+ if (gfc_match (" :: ") != MATCH_YES)
+ return MATCH_ERROR;
+ gfc_current_locus = old_locus;
+ /* Enfore F03:C401. */
+ if (ts->u.derived->attr.abstract)
+ {
+ gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+ ts->u.derived->name, &old_locus);
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+ }
+ else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
+ return MATCH_ERROR;
+
+ /* If a type is not matched, simply return MATCH_NO. */
+ gfc_current_locus = old_locus;
+ 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;
+}
+
+
+/* Match an ALLOCATE statement. */
+
+match
+gfc_match_allocate (void)
+{
+ gfc_alloc *head, *tail;
+ gfc_expr *stat, *errmsg, *tmp, *source;
+ gfc_typespec ts;
+ gfc_symbol *sym;
+ match m;
+ locus old_locus;
+ bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
+
+ head = tail = NULL;
+ stat = errmsg = source = tmp = NULL;
+ saw_stat = saw_errmsg = saw_source = false;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ /* Match an optional type-spec. */
+ old_locus = gfc_current_locus;
+ m = match_type_spec (&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)
+ head = tail = gfc_get_alloc ();
+ else
+ {
+ tail->next = gfc_get_alloc ();
+ tail = tail->next;
+ }
+
+ m = gfc_match_variable (&tail->expr, 0);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_check_do_variable (tail->expr->symtree))
+ goto cleanup;
+
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
+ {
+ 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 F03:C624. */
+ if (!gfc_type_compatible (&tail->expr->ts, &ts))
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "typespec", &tail->expr->where);
+ goto cleanup;
+ }
+
+ /* Enforce F03: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.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+
+ /* FIXME: disable the checking on derived types and arrays. */
+ sym = tail->expr->symtree->n.sym;
+ b1 = !(tail->expr->ref
+ && (tail->expr->ref->type == REF_COMPONENT
+ || tail->expr->ref->type == REF_ARRAY));
+ if (sym && sym->ts.type == BT_CLASS)
+ b2 = !(sym->ts.u.derived->components->attr.allocatable
+ || sym->ts.u.derived->components->attr.pointer);
+ else
+ b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+ || sym->attr.proc_pointer);
+ b3 = sym && sym->ns && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.allocatable
+ || sym->ns->proc_name->attr.pointer
+ || 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_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;
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 2 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;
+ }
+
+ source = tmp;
+ saw_source = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
gfc_gobble_whitespace ();
if (gfc_peek_char () == ')')
new_st.op = EXEC_ALLOCATE;
new_st.expr1 = stat;
new_st.expr2 = errmsg;
- new_st.ext.alloc_list = head;
+ new_st.expr3 = source;
+ new_st.ext.alloc.list = head;
+ new_st.ext.alloc.ts = ts;
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;
}
{
gfc_alloc *head, *tail;
gfc_expr *stat, *errmsg, *tmp;
+ gfc_symbol *sym;
match m;
- bool saw_stat, saw_errmsg;
+ bool saw_stat, saw_errmsg, b1, b2;
head = tail = NULL;
stat = errmsg = tmp = NULL;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
+ sym = tail->expr->symtree->n.sym;
+
+ if (gfc_pure (NULL) && gfc_impure_variable (sym))
{
gfc_error ("Illegal allocate-object at %C for a PURE procedure");
goto cleanup;
}
/* FIXME: disable the checking on derived types. */
- 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));
+ if (sym && sym->ts.type == BT_CLASS)
+ b2 = !(sym->ts.u.derived->components->attr.allocatable
+ || sym->ts.u.derived->components->attr.pointer);
+ else
+ b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+ || sym->attr.proc_pointer);
+ if (b1 && b2)
{
gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
"or an allocatable variable");
new_st.op = EXEC_DEALLOCATE;
new_st.expr1 = stat;
new_st.expr2 = errmsg;
- new_st.ext.alloc_list = head;
+ new_st.ext.alloc.list = head;
return MATCH_YES;
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;
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
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 && sym->ts.type == BT_DERIVED)
+ 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);
/* If it does not seem to be callable (include functions so that the
{
/* ...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)
/* 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;
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);
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;
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:
/* If the case construct doesn't have a case-construct-name, we
should have matched the EOS. */
if (!gfc_current_block ())
- {
- gfc_error ("Expected the name of the SELECT CASE construct at %C");
- return MATCH_ERROR;
- }
+ return MATCH_NO;
gfc_gobble_whitespace ();
if (strcmp (name, gfc_current_block ()->name) != 0)
{
- gfc_error ("Expected case name of '%s' at %C",
+ gfc_error ("Expected block name '%s' of SELECT construct at %C",
gfc_current_block ()->name);
return MATCH_ERROR;
}
}
+/* 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 *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 ( ");
+ if (m != MATCH_YES)
+ return m;
+
+ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+ m = gfc_match (" %n => %e", name, &expr2);
+ if (m == MATCH_YES)
+ {
+ 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. */
+ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
+ {
+ gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+ "use associate-name=>");
+ return MATCH_ERROR;
+ }
+
+ /* Check for F03:C813. */
+ if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
+ {
+ gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_SELECT_TYPE;
+ new_st.expr1 = expr1;
+ new_st.expr2 = expr2;
+ new_st.ext.ns = gfc_current_ns;
+
+ select_type_push (expr1->symtree->n.sym);
+
+ return MATCH_YES;
+}
+
+
/* Match a CASE statement. */
match
return MATCH_YES;
syntax:
- gfc_error ("Syntax error in CASE-specification at %C");
+ gfc_error ("Syntax error in CASE specification at %C");
cleanup:
gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */
return MATCH_ERROR;
}
+
+/* Match a TYPE IS statement. */
+
+match
+gfc_match_type_is (void)
+{
+ gfc_case *c = NULL;
+ match m;
+
+ if (gfc_current_state () != COMP_SELECT_TYPE)
+ {
+ gfc_error ("Unexpected TYPE IS statement at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ c = gfc_get_case ();
+ c->where = gfc_current_locus;
+
+ /* TODO: Once unlimited polymorphism is implemented, we will need to call
+ match_type_spec here. */
+ if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+
+ m = match_case_eos ();
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ new_st.op = EXEC_SELECT_TYPE;
+ new_st.ext.case_list = c;
+
+ /* Create temporary variable. */
+ select_type_set_tmp (&c->ts);
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in TYPE IS specification at %C");
+
+cleanup:
+ if (c != NULL)
+ gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
+ return MATCH_ERROR;
+}
+
+
+/* Match a CLASS IS or CLASS DEFAULT statement. */
+
+match
+gfc_match_class_is (void)
+{
+ gfc_case *c = NULL;
+ match m;
+
+ if (gfc_current_state () != COMP_SELECT_TYPE)
+ return MATCH_NO;
+
+ if (gfc_match ("% default") == MATCH_YES)
+ {
+ m = match_case_eos ();
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ new_st.op = EXEC_SELECT_TYPE;
+ c = gfc_get_case ();
+ c->where = gfc_current_locus;
+ c->ts.type = BT_UNKNOWN;
+ new_st.ext.case_list = c;
+ return MATCH_YES;
+ }
+
+ m = gfc_match ("% is");
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ c = gfc_get_case ();
+ c->where = gfc_current_locus;
+
+ if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+ goto cleanup;
+
+ if (c->ts.type == BT_DERIVED)
+ c->ts.type = BT_CLASS;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+
+ m = match_case_eos ();
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ new_st.op = EXEC_SELECT_TYPE;
+ new_st.ext.case_list = c;
+
+ /* Create temporary variable. */
+ select_type_set_tmp (&c->ts);
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in CLASS IS specification at %C");
+
+cleanup:
+ if (c != NULL)
+ gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
+ return MATCH_ERROR;
+}
+
+
/********************* WHERE subroutines ********************/
/* Match the rest of a simple WHERE statement that follows an IF statement.
OSDN Git Service
