summaryrefslogtreecommitdiff
path: root/gcc/fortran/decl.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/decl.c')
-rw-r--r--gcc/fortran/decl.c195
1 files changed, 95 insertions, 100 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 26b5059cd9f..efd21dc7ec7 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
@@ -268,7 +269,7 @@ var_element (gfc_data_variable *new_var)
if (gfc_current_state () != COMP_BLOCK_DATA
&& sym->attr.in_common
- && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
+ && gfc_notify_std (GFC_STD_GNU, "initialization of "
"common block variable '%s' in DATA statement at %C",
sym->name) == FAILURE)
return MATCH_ERROR;
@@ -588,11 +589,18 @@ cleanup:
/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
-static void
+static gfc_try
merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
+ if ((from->type == AS_ASSUMED_RANK && to->corank)
+ || (to->type == AS_ASSUMED_RANK && from->corank))
+ {
+ gfc_error ("The assumed-rank array at %C shall not have a codimension");
+ return FAILURE;
+ }
+
if (to->rank == 0 && from->rank > 0)
{
to->rank = from->rank;
@@ -638,6 +646,8 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
}
}
}
+
+ return SUCCESS;
}
@@ -676,7 +686,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
if (gfc_match_char (':') == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+ if (gfc_notify_std (GFC_STD_F2003, "deferred type "
"parameter at %C") == FAILURE)
return MATCH_ERROR;
@@ -722,7 +732,7 @@ syntax:
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr **expr, bool *deferred)
+match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
{
int length;
match m;
@@ -738,8 +748,9 @@ match_char_length (gfc_expr **expr, bool *deferred)
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
- "Old-style character length at %C") == FAILURE)
+ if (obsolescent_check
+ && gfc_notify_std (GFC_STD_F95_OBS,
+ "Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
*expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
@@ -880,7 +891,6 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
return rc;
sym = *result;
- gfc_current_ns->refs++;
if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
{
@@ -1026,8 +1036,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
- else
- gfc_warning ("Variable '%s' at %L is a parameter to the "
+ else if (gfc_option.warn_c_binding_type)
+ gfc_warning ("Variable '%s' at %L is a dummy argument of the "
"BIND(C) procedure '%s' but may not be C "
"interoperable",
sym->name, &(sym->declared_at),
@@ -1081,7 +1091,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
retval = FAILURE;
}
else if (sym->attr.optional == 1
- && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' "
+ && gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' "
"at %L with OPTIONAL attribute in "
"procedure '%s' which is BIND(C)",
sym->name, &(sym->declared_at),
@@ -1090,29 +1100,15 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
retval = FAILURE;
/* Make sure that if it has the dimension attribute, that it is
- either assumed size or explicit shape. */
- if (sym->as != NULL)
- {
- if (sym->as->type == AS_ASSUMED_SHAPE)
- {
- gfc_error ("Assumed-shape array '%s' at %L cannot be an "
- "argument to the procedure '%s' at %L because "
- "the procedure is BIND(C)", sym->name,
- &(sym->declared_at), sym->ns->proc_name->name,
- &(sym->ns->proc_name->declared_at));
- retval = FAILURE;
- }
-
- if (sym->as->type == AS_DEFERRED)
- {
- gfc_error ("Deferred-shape array '%s' at %L cannot be an "
- "argument to the procedure '%s' at %L because "
- "the procedure is BIND(C)", sym->name,
- &(sym->declared_at), sym->ns->proc_name->name,
- &(sym->ns->proc_name->declared_at));
- retval = FAILURE;
- }
- }
+ either assumed size or explicit shape. Deferred shape is already
+ covered by the pointer/allocatable attribute. */
+ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
+ && gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
+ "at %L as dummy argument to the BIND(C) "
+ "procedure '%s' at %L", sym->name,
+ &(sym->declared_at), sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at)) == FAILURE)
+ retval = FAILURE;
}
}
@@ -1737,7 +1733,7 @@ match_pointer_init (gfc_expr **init, int procptr)
if (!procptr)
gfc_resolve_expr (*init);
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
+ if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
@@ -1808,8 +1804,12 @@ variable_decl (int elem)
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
- else if (current_as)
- merge_array_spec (current_as, as, true);
+ else if (current_as
+ && merge_array_spec (current_as, as, true) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
if (gfc_option.flag_cray_pointer)
cp_as = gfc_copy_array_spec (as);
@@ -1834,7 +1834,7 @@ variable_decl (int elem)
if (as->type == AS_IMPLIED_SHAPE
&& gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: Implied-shape array at %L",
+ "Implied-shape array at %L",
&var_locus) == FAILURE)
{
m = MATCH_ERROR;
@@ -1848,7 +1848,7 @@ variable_decl (int elem)
if (current_ts.type == BT_CHARACTER)
{
- switch (match_char_length (&char_len, &cl_deferred))
+ switch (match_char_length (&char_len, &cl_deferred, false))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
@@ -1993,7 +1993,7 @@ variable_decl (int elem)
if (!colon_seen && gfc_match (" /") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
+ if (gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
@@ -2410,7 +2410,7 @@ gfc_match_char_spec (gfc_typespec *ts)
/* Try the old-style specification first. */
old_char_selector = 0;
- m = match_char_length (&len, &deferred);
+ m = match_char_length (&len, &deferred, true);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
@@ -2586,7 +2586,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
if (gfc_match (" byte") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
+ if (gfc_notify_std (GFC_STD_GNU, "BYTE type at %C")
== FAILURE)
return MATCH_ERROR;
@@ -2617,7 +2617,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
gfc_error ("Assumed type at %C is not allowed for components");
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type "
+ if (gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
"at %C") == FAILURE)
return MATCH_ERROR;
ts->type = BT_ASSUMED;
@@ -2640,7 +2640,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
|| (!matched_type && gfc_match (" character") == MATCH_YES))
{
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ && gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
@@ -2671,7 +2671,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
|| (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ && gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
@@ -2696,12 +2696,12 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
&& gfc_match (" complex") == MATCH_YES)))
|| (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+ if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")
== FAILURE)
return MATCH_ERROR;
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ && gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
@@ -2743,7 +2743,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return m;
ts->type = BT_CLASS;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")
== FAILURE)
return MATCH_ERROR;
}
@@ -2851,7 +2851,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
get_kind:
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ && gfc_notify_std (GFC_STD_F2008, "TYPE with "
"intrinsic-type-spec at %C") == FAILURE)
return MATCH_ERROR;
@@ -3136,7 +3136,7 @@ gfc_match_import (void)
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -3521,7 +3521,8 @@ match_attr_spec (void)
current_as = as;
else if (m == MATCH_YES)
{
- merge_array_spec (as, current_as, false);
+ if (merge_array_spec (as, current_as, false) == FAILURE)
+ m = MATCH_ERROR;
free (as);
}
@@ -3632,7 +3633,7 @@ match_attr_spec (void)
{
if (d == DECL_ALLOCATABLE)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
+ if (gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
"attribute at %C in a TYPE definition")
== FAILURE)
{
@@ -3660,7 +3661,7 @@ match_attr_spec (void)
&& gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_MODULE)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
+ if (gfc_notify_std (GFC_STD_F2003, "Attribute %s "
"at %L in a TYPE definition", attr,
&seen_at[d])
== FAILURE)
@@ -3686,7 +3687,7 @@ match_attr_spec (void)
case DECL_ASYNCHRONOUS:
if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: ASYNCHRONOUS attribute at %C")
+ "ASYNCHRONOUS attribute at %C")
== FAILURE)
t = FAILURE;
else
@@ -3699,7 +3700,7 @@ match_attr_spec (void)
case DECL_CONTIGUOUS:
if (gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: CONTIGUOUS attribute at %C")
+ "CONTIGUOUS attribute at %C")
== FAILURE)
t = FAILURE;
else
@@ -3751,7 +3752,7 @@ match_attr_spec (void)
break;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
+ if (gfc_notify_std (GFC_STD_F2003, "PROTECTED "
"attribute at %C")
== FAILURE)
t = FAILURE;
@@ -3782,7 +3783,7 @@ match_attr_spec (void)
break;
case DECL_VALUE:
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
+ if (gfc_notify_std (GFC_STD_F2003, "VALUE attribute "
"at %C")
== FAILURE)
t = FAILURE;
@@ -3792,7 +3793,7 @@ match_attr_spec (void)
case DECL_VOLATILE:
if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: VOLATILE attribute at %C")
+ "VOLATILE attribute at %C")
== FAILURE)
t = FAILURE;
else
@@ -4372,7 +4373,7 @@ gfc_match_prefix (gfc_typespec *ts)
if (gfc_match ("impure% ") == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: IMPURE procedure at %C")
+ "IMPURE procedure at %C")
== FAILURE)
goto error;
@@ -4658,7 +4659,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
/* Fortran 2008 draft allows BIND(C) for internal procedures. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
+ && gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
"at %L may not be specified for an internal "
"procedure", &gfc_current_locus)
== FAILURE)
@@ -4790,41 +4791,20 @@ match_procedure_interface (gfc_symbol **proc_if)
gfc_current_ns = old_ns;
*proc_if = st->n.sym;
- /* Various interface checks. */
if (*proc_if)
{
(*proc_if)->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
- invalid per C1212. */
+ invalid per F08:C1216 (cf. resolve_procedure_interface). */
while ((*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
- if ((*proc_if)->generic)
- {
- gfc_error ("Interface '%s' at %C may not be generic",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Interface '%s' at %C may not be a statement function",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- /* Handle intrinsic procedures. */
- if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
- || (*proc_if)->attr.if_source == IFSRC_IFBODY)
- && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
- || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
- (*proc_if)->attr.intrinsic = 1;
- if ((*proc_if)->attr.intrinsic
- && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
- {
- gfc_error ("Intrinsic procedure '%s' not allowed "
- "in PROCEDURE statement at %C", (*proc_if)->name);
- return MATCH_ERROR;
- }
+ if ((*proc_if)->attr.flavor == FL_UNKNOWN
+ && (*proc_if)->ts.type == BT_UNKNOWN
+ && gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
+ (*proc_if)->name, NULL) == FAILURE)
+ return MATCH_ERROR;
}
got_ts:
@@ -5029,7 +5009,7 @@ match_ppc_decl (void)
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure pointer "
+ if (gfc_notify_std (GFC_STD_F2003, "Procedure pointer "
"component at %C") == FAILURE)
return MATCH_ERROR;
@@ -5069,6 +5049,7 @@ match_ppc_decl (void)
{
c->ts = ts;
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+ c->ts.interface->result = c->ts.interface;
c->ts.interface->ts = ts;
c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
@@ -5107,6 +5088,7 @@ match_procedure_in_interface (void)
match m;
gfc_symbol *sym;
char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
if (current_interface.type == INTERFACE_NAMELESS
|| current_interface.type == INTERFACE_ABSTRACT)
@@ -5115,6 +5097,19 @@ match_procedure_in_interface (void)
return MATCH_ERROR;
}
+ /* Check if the F2008 optional double colon appears. */
+ gfc_gobble_whitespace ();
+ old_locus = gfc_current_locus;
+ if (gfc_match ("::") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "double colon in "
+ "MODULE PROCEDURE statement at %L", &old_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+ else
+ gfc_current_locus = old_locus;
+
for(;;)
{
m = gfc_match_name (name);
@@ -5177,7 +5172,7 @@ gfc_match_procedure (void)
if (m != MATCH_YES)
return m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -5388,7 +5383,7 @@ gfc_match_entry (void)
if (m != MATCH_YES)
return m;
- if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: "
+ if (gfc_notify_std (GFC_STD_F2008_OBS,
"ENTRY statement at %C") == FAILURE)
return MATCH_ERROR;
@@ -5699,7 +5694,7 @@ gfc_match_subroutine (void)
/* The following is allowed in the Fortran 2008 draft. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
+ && gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
"at %L may not be specified for an internal "
"procedure", &gfc_current_locus)
== FAILURE)
@@ -6069,7 +6064,7 @@ gfc_match_end (gfc_statement *st)
{
if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
+ if (gfc_notify_std (GFC_STD_F2008, "END statement "
"instead of %s statement at %L",
gfc_ascii_statement (*st), &old_loc) == FAILURE)
goto cleanup;
@@ -6595,7 +6590,7 @@ gfc_match_codimension (void)
match
gfc_match_contiguous (void)
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
+ if (gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -6748,7 +6743,7 @@ gfc_match_protected (void)
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -7046,7 +7041,7 @@ gfc_match_value (void)
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -7097,7 +7092,7 @@ gfc_match_volatile (void)
gfc_symbol *sym;
match m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -7158,7 +7153,7 @@ gfc_match_asynchronous (void)
gfc_symbol *sym;
match m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS statement at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C")
== FAILURE)
return MATCH_ERROR;
@@ -7249,7 +7244,7 @@ gfc_match_modproc (void)
old_locus = gfc_current_locus;
if (gfc_match ("::") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in "
+ if (gfc_notify_std (GFC_STD_F2008, "double colon in "
"MODULE PROCEDURE statement at %L", &old_locus)
== FAILURE)
return MATCH_ERROR;
@@ -7416,7 +7411,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
}
else if (gfc_match (" , abstract") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT type at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C")
== FAILURE)
return MATCH_ERROR;
@@ -7647,7 +7642,7 @@ gfc_match_enum (void)
if (m != MATCH_YES)
return m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
+ if (gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C")
== FAILURE)
return MATCH_ERROR;
@@ -8141,7 +8136,7 @@ match_procedure_in_type (void)
return MATCH_ERROR;
}
- if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
+ if (num>1 && gfc_notify_std (GFC_STD_F2008, "PROCEDURE list"
" at %C") == FAILURE)
return MATCH_ERROR;
View Lorry Controller Status