for (; p; p = q)
{
q = p->next;
+ mpz_clear (p->repeat);
gfc_free_expr (p->expr);
gfc_free (p);
}
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
- " procedure '%s' but is not C interoperable "
+ "procedure '%s' but is not C interoperable "
"because derived type '%s' is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
sym->attr.implied_index = 0;
- if (sym->ts.type == BT_CLASS)
- {
- sym->attr.class_ok = (sym->attr.dummy
- || sym->attr.pointer
- || sym->attr.allocatable) ? 1 : 0;
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
- }
+ if (sym->ts.type == BT_CLASS
+ && (sym->attr.class_ok = sym->attr.dummy || sym->attr.pointer
+ || sym->attr.allocatable))
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return SUCCESS;
}
}
/* Check if the assignment can happen. This has to be put off
- until later for a derived type variable. */
+ until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
+ && !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
}
}
+ /* If sym is implied-shape, set its upper bounds from init. */
+ if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
+ && sym->as->type == AS_IMPLIED_SHAPE)
+ {
+ int dim;
+
+ if (init->rank == 0)
+ {
+ gfc_error ("Can't initialize implied-shape array at %L"
+ " with scalar", &sym->declared_at);
+ return FAILURE;
+ }
+ gcc_assert (sym->as->rank == init->rank);
+
+ /* Shape should be present, we get an initialization expression. */
+ gcc_assert (init->shape);
+
+ for (dim = 0; dim < sym->as->rank; ++dim)
+ {
+ int k;
+ gfc_expr* lower;
+ gfc_expr* e;
+
+ lower = sym->as->lower[dim];
+ if (lower->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Non-constant lower bound in implied-shape"
+ " declaration at %L", &lower->where);
+ return FAILURE;
+ }
+
+ /* All dimensions must be without upper bound. */
+ gcc_assert (!sym->as->upper[dim]);
+
+ k = lower->ts.kind;
+ e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
+ mpz_add (e->value.integer,
+ lower->value.integer, init->shape[dim]);
+ mpz_sub_ui (e->value.integer, e->value.integer, 1);
+ sym->as->upper[dim] = e;
+ }
+
+ sym->as->type = AS_EXPLICIT;
+ }
+
/* Need to check if the expression we initialized this
to was one of the iso_c_binding named constants. If so,
and we're a parameter (constant), let it be iso_c.
}
+/* Match the initialization expr for a data pointer or procedure pointer. */
+
+static match
+match_pointer_init (gfc_expr **init, int procptr)
+{
+ match m;
+
+ if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
+ {
+ gfc_error ("Initialization of pointer at %C is not allowed in "
+ "a PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ /* Match NULL() initilization. */
+ m = gfc_match_null (init);
+ if (m != MATCH_NO)
+ return m;
+
+ /* Match non-NULL initialization. */
+ gfc_matching_procptr_assignment = procptr;
+ m = gfc_match_rvalue (init);
+ gfc_matching_procptr_assignment = 0;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ else if (m == MATCH_NO)
+ {
+ gfc_error ("Error in pointer initialization at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!procptr)
+ gfc_resolve_expr (*init);
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
+ "initialization at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
/* Match a variable name with an optional initializer. When this
subroutine is called, a variable is expected to be parsed next.
Depending on what is happening at the moment, updates either the
else if (current_as)
merge_array_spec (current_as, as, true);
+ /* At this point, we know for sure if the symbol is PARAMETER and can thus
+ determine (and check) whether it can be implied-shape. If it
+ was parsed as assumed-size, change it because PARAMETERs can not
+ be assumed-size. */
+ if (as)
+ {
+ if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
+ name, &var_locus);
+ goto cleanup;
+ }
+
+ if (as->type == AS_ASSUMED_SIZE && as->rank == 1
+ && current_attr.flavor == FL_PARAMETER)
+ as->type = AS_IMPLIED_SHAPE;
+
+ if (as->type == AS_IMPLIED_SHAPE
+ && gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: Implied-shape array at %L",
+ &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
char_len = NULL;
cl = NULL;
specified in the procedure definition, except that the interface
may specify a procedure that is not pure if the procedure is
defined to be pure(12.3.2). */
- if (current_ts.type == BT_DERIVED
+ if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& gfc_current_ns->proc_name
&& gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
&& current_ts.u.derived->ns != gfc_current_ns)
goto cleanup;
}
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
-
- if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 0);
if (m != MATCH_YES)
goto cleanup;
-
}
else if (gfc_match_char ('=') == MATCH_YES)
{
gfc_symbol *sym;
match m;
char c;
- bool seen_deferred_kind;
+ bool seen_deferred_kind, matched_type;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
return MATCH_YES;
}
- if (gfc_match (" integer") == MATCH_YES)
+
+ m = gfc_match (" type ( %n", name);
+ matched_type = (m == MATCH_YES);
+
+ if ((matched_type && strcmp ("integer", name) == 0)
+ || (!matched_type && gfc_match (" integer") == MATCH_YES))
{
ts->type = BT_INTEGER;
ts->kind = gfc_default_integer_kind;
goto get_kind;
}
- if (gfc_match (" character") == MATCH_YES)
+ if ((matched_type && strcmp ("character", name) == 0)
+ || (!matched_type && gfc_match (" character") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
- return gfc_match_char_spec (ts);
+ m = gfc_match_char_spec (ts);
else
- return MATCH_YES;
+ m = MATCH_YES;
+
+ if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+ m = MATCH_ERROR;
+
+ return m;
}
- if (gfc_match (" real") == MATCH_YES)
+ if ((matched_type && strcmp ("real", name) == 0)
+ || (!matched_type && gfc_match (" real") == MATCH_YES))
{
ts->type = BT_REAL;
ts->kind = gfc_default_real_kind;
goto get_kind;
}
- if (gfc_match (" double precision") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doubleprecision", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" precision") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
- if (gfc_match (" complex") == MATCH_YES)
+ if ((matched_type && strcmp ("complex", name) == 0)
+ || (!matched_type && gfc_match (" complex") == MATCH_YES))
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_complex_kind;
goto get_kind;
}
- if (gfc_match (" double complex") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doublecomplex", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" complex") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
- if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
- "conform to the Fortran 95 standard") == FAILURE)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
ts->type = BT_COMPLEX;
return MATCH_YES;
}
- if (gfc_match (" logical") == MATCH_YES)
+ if ((matched_type && strcmp ("logical", name) == 0)
+ || (!matched_type && gfc_match (" logical") == MATCH_YES))
{
ts->type = BT_LOGICAL;
ts->kind = gfc_default_logical_kind;
goto get_kind;
}
- m = gfc_match (" type ( %n )", name);
+ if (matched_type)
+ m = gfc_match_char (')');
+
if (m == MATCH_YES)
ts->type = BT_DERIVED;
else
return MATCH_YES;
get_kind:
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
/* For all types except double, derived and character, look for an
optional kind specifier. MATCH_NO is actually OK at this point. */
if (implicit_flag == 1)
- return MATCH_YES;
+ {
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+ }
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_ascii_char ();
if (!gfc_is_whitespace (c) && c != '*' && c != '('
&& c != ':' && c != ',')
- return MATCH_NO;
+ {
+ if (matched_type && c == ')')
+ {
+ gfc_next_ascii_char ();
+ return MATCH_YES;
+ }
+ return MATCH_NO;
+ }
}
m = gfc_match_kind_spec (ts, false);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
/* Defer association of the KIND expression of function results
until after USE and IMPORT statements. */
if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
- DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE,
- GFC_DECL_END /* Sentinel */
+ DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
+ DECL_NONE, GFC_DECL_END /* Sentinel */
}
decl_types;
}
break;
}
+ break;
case 'b':
/* Try and match the bind(c). */
break;
case 'c':
- if (match_string_p ("codimension"))
- d = DECL_CODIMENSION;
+ gfc_next_ascii_char ();
+ if ('o' != gfc_next_ascii_char ())
+ break;
+ switch (gfc_next_ascii_char ())
+ {
+ case 'd':
+ if (match_string_p ("imension"))
+ {
+ d = DECL_CODIMENSION;
+ break;
+ }
+ case 'n':
+ if (match_string_p ("tiguous"))
+ {
+ d = DECL_CONTIGUOUS;
+ break;
+ }
+ }
break;
case 'd':
case DECL_CODIMENSION:
attr = "CODIMENSION";
break;
+ case DECL_CONTIGUOUS:
+ attr = "CONTIGUOUS";
+ break;
case DECL_DIMENSION:
attr = "DIMENSION";
break;
if (gfc_current_state () == COMP_DERIVED
&& d != DECL_DIMENSION && d != DECL_CODIMENSION
&& d != DECL_POINTER && d != DECL_PRIVATE
- && d != DECL_PUBLIC && d != DECL_NONE)
+ && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
{
if (d == DECL_ALLOCATABLE)
{
t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
break;
+ case DECL_CONTIGUOUS:
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: CONTIGUOUS attribute at %C")
+ == FAILURE)
+ t = FAILURE;
+ else
+ t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_DIMENSION:
t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
}
}
+ /* Module variables implicitly have the SAVE attribute. */
+ if (gfc_current_state () == COMP_MODULE && !current_attr.save)
+ current_attr.save = SAVE_IMPLICIT;
+
colon_seen = 1;
return MATCH_YES;
verify_c_interop (gfc_typespec *ts)
{
if (ts->type == BT_DERIVED && ts->u.derived != NULL)
- return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
+ ? SUCCESS : FAILURE;
else if (ts->is_c_interop != 1)
return FAILURE;
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
+ bool seen_impure;
+ bool found_prefix;
gfc_clear_attr (¤t_attr);
- seen_type = 0;
+ seen_type = false;
+ seen_impure = false;
gcc_assert (!gfc_matching_prefix);
gfc_matching_prefix = true;
-loop:
- if (!seen_type && ts != NULL
- && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
- && gfc_match_space () == MATCH_YES)
+ do
{
+ found_prefix = false;
- seen_type = 1;
- goto loop;
- }
+ if (!seen_type && ts != NULL
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_space () == MATCH_YES)
+ {
- if (gfc_match ("elemental% ") == MATCH_YES)
- {
- if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- goto error;
+ seen_type = true;
+ found_prefix = true;
+ }
+
+ if (gfc_match ("elemental% ") == MATCH_YES)
+ {
+ if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
- goto loop;
+ if (gfc_match ("pure% ") == MATCH_YES)
+ {
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("recursive% ") == MATCH_YES)
+ {
+ if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ /* IMPURE is a somewhat special case, as it needs not set an actual
+ attribute but rather only prevents ELEMENTAL routines from being
+ automatically PURE. */
+ if (gfc_match ("impure% ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: IMPURE procedure at %C")
+ == FAILURE)
+ goto error;
+
+ seen_impure = true;
+ found_prefix = true;
+ }
}
+ while (found_prefix);
- if (gfc_match ("pure% ") == MATCH_YES)
+ /* IMPURE and PURE must not both appear, of course. */
+ if (seen_impure && current_attr.pure)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- goto error;
-
- goto loop;
+ gfc_error ("PURE and IMPURE must not appear both at %C");
+ goto error;
}
- if (gfc_match ("recursive% ") == MATCH_YES)
+ /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
+ if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
- if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
goto error;
-
- goto loop;
}
/* At this point, the next item is not a prefix. */
goto cleanup;
}
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
goto cleanup;
if (gfc_match (" =>") == MATCH_YES)
{
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
- if (gfc_pure (NULL))
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
{
gfc_free_expr (initializer);
if (m != MATCH_YES)
return m;
+ if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: "
+ "ENTRY statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
state = gfc_current_state ();
if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
if (gfc_match_eos () == MATCH_YES)
{
- if (!eos_ok)
+ if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
+ "instead of %s statement at %L",
+ gfc_ascii_statement (*st), &old_loc) == FAILURE)
+ goto cleanup;
+ }
+ else if (!eos_ok)
{
/* We would have required END [something]. */
gfc_error ("%s statement expected at %L",
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
to the first component, or '$data' field. */
- if (sym->ts.type == BT_CLASS)
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
{
if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus)
== FAILURE)
m = MATCH_ERROR;
goto cleanup;
}
- sym->attr.class_ok = (sym->attr.class_ok || current_attr.allocatable
- || current_attr.pointer);
}
else
{
goto cleanup;
}
}
+
+ if (sym->ts.type == BT_CLASS && !sym->attr.class_ok
+ && (sym->attr.class_ok = sym->attr.class_ok || current_attr.allocatable
+ || current_attr.pointer))
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
{
match
+gfc_match_contiguous (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.contiguous = 1;
+
+ return attr_decl ();
+}
+
+
+match
gfc_match_dimension (void)
{
gfc_clear_attr (¤t_attr);
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char target_buf[GFC_MAX_SYMBOL_LEN + 1];
- char* target = NULL;
- gfc_typebound_proc* tb;
+ char* target = NULL, *ifc = NULL;
+ gfc_typebound_proc tb;
bool seen_colons;
bool seen_attrs;
match m;
gfc_symtree* stree;
gfc_namespace* ns;
gfc_symbol* block;
+ int num;
/* Check current state. */
gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
return MATCH_ERROR;
}
- target = target_buf;
+ ifc = target_buf;
}
/* Construct the data structure. */
- tb = gfc_get_typebound_proc ();
- tb->where = gfc_current_locus;
- tb->is_generic = 0;
+ memset (&tb, 0, sizeof (tb));
+ tb.where = gfc_current_locus;
/* Match binding attributes. */
- m = match_binding_attributes (tb, false, false);
+ m = match_binding_attributes (&tb, false, false);
if (m == MATCH_ERROR)
return m;
seen_attrs = (m == MATCH_YES);
- /* Check that attribute DEFERRED is given iff an interface is specified, which
- means target != NULL. */
- if (tb->deferred && !target)
+ /* Check that attribute DEFERRED is given if an interface is specified. */
+ if (tb.deferred && !ifc)
{
gfc_error ("Interface must be specified for DEFERRED binding at %C");
return MATCH_ERROR;
}
- if (target && !tb->deferred)
+ if (ifc && !tb.deferred)
{
gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
return MATCH_ERROR;
return MATCH_ERROR;
}
- /* Match the binding name. */
- m = gfc_match_name (name);
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Expected binding name at %C");
- return MATCH_ERROR;
- }
-
- /* Try to match the '=> target', if it's there. */
- m = gfc_match (" =>");
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_YES)
+ /* Match the binding names. */
+ for(num=1;;num++)
{
- if (tb->deferred)
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
{
- gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ gfc_error ("Expected binding name at %C");
return MATCH_ERROR;
}
- if (!seen_colons)
- {
- gfc_error ("'::' needed in PROCEDURE binding with explicit target"
- " at %C");
- return MATCH_ERROR;
- }
+ if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+ " at %C") == FAILURE)
+ return MATCH_ERROR;
- m = gfc_match_name (target_buf);
+ /* Try to match the '=> target', if it's there. */
+ target = ifc;
+ m = gfc_match (" =>");
if (m == MATCH_ERROR)
return m;
- if (m == MATCH_NO)
+ if (m == MATCH_YES)
{
- gfc_error ("Expected binding target after '=>' at %C");
- return MATCH_ERROR;
+ if (tb.deferred)
+ {
+ gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!seen_colons)
+ {
+ gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
}
- target = target_buf;
- }
- /* Now we should have the end. */
- m = gfc_match_eos ();
- if (m == MATCH_ERROR)
- return m;
- if (m == MATCH_NO)
- {
- gfc_error ("Junk after PROCEDURE declaration at %C");
- return MATCH_ERROR;
- }
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
- /* If no target was found, it has the same name as the binding. */
- if (!target)
- target = name;
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
- /* Get the namespace to insert the symbols into. */
- ns = block->f2k_derived;
- gcc_assert (ns);
+ /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
+ if (tb.deferred && !block->attr.abstract)
+ {
+ gfc_error ("Type '%s' containing DEFERRED binding at %C "
+ "is not ABSTRACT", block->name);
+ return MATCH_ERROR;
+ }
- /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
- if (tb->deferred && !block->attr.abstract)
- {
- gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
- block->name);
- return MATCH_ERROR;
- }
+ /* See if we already have a binding with this name in the symtree which
+ would be an error. If a GENERIC already targetted this binding, it may
+ be already there but then typebound is still NULL. */
+ stree = gfc_find_symtree (ns->tb_sym_root, name);
+ if (stree && stree->n.tb)
+ {
+ gfc_error ("There is already a procedure with binding name '%s' for "
+ "the derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
- /* See if we already have a binding with this name in the symtree which would
- be an error. If a GENERIC already targetted this binding, it may be
- already there but then typebound is still NULL. */
- stree = gfc_find_symtree (ns->tb_sym_root, name);
- if (stree && stree->n.tb)
- {
- gfc_error ("There's already a procedure with binding name '%s' for the"
- " derived type '%s' at %C", name, block->name);
- return MATCH_ERROR;
- }
+ /* Insert it and set attributes. */
- /* Insert it and set attributes. */
+ if (!stree)
+ {
+ stree = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (stree);
+ }
+ stree->n.tb = gfc_get_typebound_proc (&tb);
- if (!stree)
- {
- stree = gfc_new_symtree (&ns->tb_sym_root, name);
- gcc_assert (stree);
+ if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
+ false))
+ return MATCH_ERROR;
+ gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
+
+ if (gfc_match_eos () == MATCH_YES)
+ return MATCH_YES;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
}
- stree->n.tb = tb;
-
- if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
- return MATCH_ERROR;
- gfc_set_sym_referenced (tb->u.specific->n.sym);
- return MATCH_YES;
+syntax:
+ gfc_error ("Syntax error in PROCEDURE statement at %C");
+ return MATCH_ERROR;
}
ns = block->f2k_derived;
gcc_assert (block && ns);
+ memset (&tbattr, 0, sizeof (tbattr));
+ tbattr.where = gfc_current_locus;
+
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true, false);
if (m == MATCH_ERROR)
}
else
{
- tb = gfc_get_typebound_proc ();
+ tb = gfc_get_typebound_proc (NULL);
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
OSDN Git Service
