diff options
Diffstat (limited to 'gcc/fortran/decl.c')
| -rw-r--r-- | gcc/fortran/decl.c | 110 |
1 files changed, 74 insertions, 36 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9beb4eef455..52a98cd44ed 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -6169,13 +6169,17 @@ gfc_match_prefix (gfc_typespec *ts) found_prefix = true; } - if (!seen_type && ts != NULL - && gfc_match_decl_type_spec (ts, 0) == MATCH_YES - && gfc_match_space () == MATCH_YES) + if (!seen_type && ts != NULL) { - - seen_type = true; - found_prefix = true; + match m; + m = gfc_match_decl_type_spec (ts, 0); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES && gfc_match_space () == MATCH_YES) + { + seen_type = true; + found_prefix = true; + } } if (gfc_match ("elemental% ") == MATCH_YES) @@ -7226,13 +7230,16 @@ gfc_match_function_decl (void) if (sym->attr.is_bind_c == 1) { sym->attr.is_bind_c = 0; - if (sym->old_symbol != NULL) - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", - &(sym->old_symbol->declared_at)); - else - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &gfc_current_locus); + + if (gfc_state_stack->previous + && gfc_state_stack->previous->state != COMP_SUBMODULE) + { + locus loc; + loc = sym->old_symbol != NULL + ? sym->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } } if (found_match != MATCH_YES) @@ -7246,6 +7253,24 @@ gfc_match_function_decl (void) found_match = suffix_match; } + /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module + subprogram and a binding label is specified, it shall be the + same as the binding label specified in the corresponding module + procedure interface body. */ + if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol + && strcmp (sym->name, sym->old_symbol->name) == 0 + && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) + { + const char *null = "NULL", *s1, *s2; + s1 = sym->binding_label; + if (!s1) s1 = null; + s2 = sym->old_symbol->binding_label; + if (!s2) s2 = null; + gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); + sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ + return MATCH_ERROR; + } + if(found_match != MATCH_YES) m = MATCH_ERROR; else @@ -7484,15 +7509,15 @@ gfc_match_entry (void) not allowed for procedures. */ if (entry->attr.is_bind_c == 1) { + locus loc; + entry->attr.is_bind_c = 0; - if (entry->old_symbol != NULL) - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", - &(entry->old_symbol->declared_at)); - else - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &gfc_current_locus); - } + + loc = entry->old_symbol != NULL + ? entry->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } /* Check what next non-whitespace character is so we can tell if there is the required parens if we have a BIND(C). */ @@ -7692,13 +7717,16 @@ gfc_match_subroutine (void) if (sym->attr.is_bind_c == 1) { sym->attr.is_bind_c = 0; - if (sym->old_symbol != NULL) - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", - &(sym->old_symbol->declared_at)); - else - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &gfc_current_locus); + + if (gfc_state_stack->previous + && gfc_state_stack->previous->state != COMP_SUBMODULE) + { + locus loc; + loc = sym->old_symbol != NULL + ? sym->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } } /* C binding names are not allowed for internal procedures. */ @@ -7740,6 +7768,24 @@ gfc_match_subroutine (void) return MATCH_ERROR; } + /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module + subprogram and a binding label is specified, it shall be the + same as the binding label specified in the corresponding module + procedure interface body. */ + if (sym->attr.module_procedure && sym->old_symbol + && strcmp (sym->name, sym->old_symbol->name) == 0 + && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) + { + const char *null = "NULL", *s1, *s2; + s1 = sym->binding_label; + if (!s1) s1 = null; + s2 = sym->old_symbol->binding_label; + if (!s2) s2 = null; + gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); + sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ + return MATCH_ERROR; + } + /* Scan the dummy arguments for an alternate return. */ for (arg = sym->formal; arg; arg = arg->next) if (!arg->sym) @@ -8444,14 +8490,6 @@ attr_decl1 (void) goto cleanup; } - /* Check F2018:C822. */ - if (sym->attr.dimension && sym->attr.codimension - && sym->as && sym->as->rank + sym->as->corank > 15) - { - gfc_error ("rank + corank of %qs exceeds 15 at %C", sym->name); - return MATCH_ERROR; - } - if (sym->attr.cray_pointee && sym->as != NULL) { /* Fix the array spec. */ |