diff options
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 1131 |
1 files changed, 806 insertions, 325 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 5bd1279291..6fe0647ecf 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1,5 +1,5 @@ /* Deal with interfaces. - Copyright (C) 2000-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2017 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -115,6 +115,21 @@ fold_unary_intrinsic (gfc_intrinsic_op op) } +/* Return the operator depending on the DTIO moded string. Note that + these are not operators in the normal sense and so have been placed + beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */ + +static gfc_intrinsic_op +dtio_op (char* mode) +{ + if (strncmp (mode, "formatted", 9) == 0) + return INTRINSIC_FORMATTED; + if (strncmp (mode, "unformatted", 9) == 0) + return INTRINSIC_UNFORMATTED; + return INTRINSIC_NONE; +} + + /* Match a generic specification. Depending on which type of interface is found, the 'name' or 'op' pointers may be set. This subroutine doesn't return MATCH_NO. */ @@ -162,6 +177,40 @@ gfc_match_generic_spec (interface_type *type, return MATCH_YES; } + if (gfc_match (" read ( %n )", buffer) == MATCH_YES) + { + *op = dtio_op (buffer); + if (*op == INTRINSIC_FORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_RF)); + *type = INTERFACE_DTIO; + } + if (*op == INTRINSIC_UNFORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF)); + *type = INTERFACE_DTIO; + } + if (*op != INTRINSIC_NONE) + return MATCH_YES; + } + + if (gfc_match (" write ( %n )", buffer) == MATCH_YES) + { + *op = dtio_op (buffer); + if (*op == INTRINSIC_FORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_WF)); + *type = INTERFACE_DTIO; + } + if (*op == INTRINSIC_UNFORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF)); + *type = INTERFACE_DTIO; + } + if (*op != INTRINSIC_NONE) + return MATCH_YES; + } + if (gfc_match_name (buffer) == MATCH_YES) { strcpy (name, buffer); @@ -209,6 +258,7 @@ gfc_match_interface (void) switch (type) { + case INTERFACE_DTIO: case INTERFACE_GENERIC: if (gfc_get_symbol (name, NULL, &sym)) return MATCH_ERROR; @@ -348,10 +398,10 @@ gfc_match_end_interface (void) m = MATCH_ERROR; if (strcmp(s2, "none") == 0) gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> " - "at %C, ", s1); - else + "at %C", s1); + else gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, " - "but got %s", s1, s2); + "but got %qs", s1, s2); } } @@ -371,6 +421,7 @@ gfc_match_end_interface (void) break; + case INTERFACE_DTIO: case INTERFACE_GENERIC: if (type != current_interface.type || strcmp (current_interface.sym->name, name) != 0) @@ -387,59 +438,90 @@ gfc_match_end_interface (void) } +/* Return whether the component was defined anonymously. */ + +static bool +is_anonymous_component (gfc_component *cmp) +{ + /* Only UNION and MAP components are anonymous. In the case of a MAP, + the derived type symbol is FL_STRUCT and the component name looks like mM*. + This is the only case in which the second character of a component name is + uppercase. */ + return cmp->ts.type == BT_UNION + || (cmp->ts.type == BT_DERIVED + && cmp->ts.u.derived->attr.flavor == FL_STRUCT + && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1])); +} + + +/* Return whether the derived type was defined anonymously. */ + +static bool +is_anonymous_dt (gfc_symbol *derived) +{ + /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE + types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT + and the type name looks like XX*. This is the only case in which the + second character of a type name is uppercase. */ + return derived->attr.flavor == FL_UNION + || (derived->attr.flavor == FL_STRUCT + && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1])); +} + + /* Compare components according to 4.4.2 of the Fortran standard. */ -static int +static bool compare_components (gfc_component *cmp1, gfc_component *cmp2, gfc_symbol *derived1, gfc_symbol *derived2) { - gfc_symbol *d1, *d2; - bool anonymous = false; - - /* Unions, maps, and anonymous structures all have names like "[xX]X$\d+" - which should not be compared. */ - d1 = cmp1->ts.u.derived; - d2 = cmp2->ts.u.derived; - if ( (d1 && (d1->attr.flavor == FL_STRUCT || d1->attr.flavor == FL_UNION) - && ISUPPER (cmp1->name[1])) - || (d2 && (d2->attr.flavor == FL_STRUCT || d2->attr.flavor == FL_UNION) - && ISUPPER (cmp1->name[1]))) - anonymous = true; - - if (!anonymous && strcmp (cmp1->name, cmp2->name) != 0) - return 0; + /* Compare names, but not for anonymous components such as UNION or MAP. */ + if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2) + && strcmp (cmp1->name, cmp2->name) != 0) + return false; if (cmp1->attr.access != cmp2->attr.access) - return 0; + return false; if (cmp1->attr.pointer != cmp2->attr.pointer) - return 0; + return false; if (cmp1->attr.dimension != cmp2->attr.dimension) - return 0; + return false; if (cmp1->attr.allocatable != cmp2->attr.allocatable) - return 0; + return false; if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) - return 0; + return false; + + if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER) + { + gfc_charlen *l1 = cmp1->ts.u.cl; + gfc_charlen *l2 = cmp2->ts.u.cl; + if (l1 && l2 && l1->length && l2->length + && l1->length->expr_type == EXPR_CONSTANT + && l2->length->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (l1->length, l2->length) != 0) + return false; + } /* Make sure that link lists do not put this function into an endless recursive loop! */ if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived) - && gfc_compare_types (&cmp1->ts, &cmp2->ts) == 0) - return 0; + && !gfc_compare_types (&cmp1->ts, &cmp2->ts)) + return false; else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) - return 0; + return false; else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) - return 0; + return false; - return 1; + return true; } @@ -451,13 +533,20 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2, gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate definitions' than 'equivalent structure'. */ -int -gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2) +static bool +compare_union_types (gfc_symbol *un1, gfc_symbol *un2) { gfc_component *map1, *map2, *cmp1, *cmp2; + gfc_symbol *map1_t, *map2_t; if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION) - return 0; + return false; + + if (un1->attr.zero_comp != un2->attr.zero_comp) + return false; + + if (un1->attr.zero_comp) + return true; map1 = un1->components; map2 = un2->components; @@ -469,38 +558,48 @@ gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2) we will say they are not equal for the purposes of this test; therefore we compare the maps sequentially. */ for (;;) - { - cmp1 = map1->ts.u.derived->components; - cmp2 = map2->ts.u.derived->components; - for (;;) - { - /* No two fields will ever point to the same map type unless they are - the same component, because one map field is created with its type - declaration. Therefore don't worry about recursion here. */ - /* TODO: worry about recursion into parent types of the unions? */ - if (compare_components (cmp1, cmp2, - map1->ts.u.derived, map2->ts.u.derived) == 0) - return 0; + { + map1_t = map1->ts.u.derived; + map2_t = map2->ts.u.derived; - cmp1 = cmp1->next; - cmp2 = cmp2->next; + cmp1 = map1_t->components; + cmp2 = map2_t->components; - if (cmp1 == NULL && cmp2 == NULL) - break; - if (cmp1 == NULL || cmp2 == NULL) - return 0; - } + /* Protect against null components. */ + if (map1_t->attr.zero_comp != map2_t->attr.zero_comp) + return false; - map1 = map1->next; - map2 = map2->next; + if (map1_t->attr.zero_comp) + return true; - if (map1 == NULL && map2 == NULL) - break; - if (map1 == NULL || map2 == NULL) - return 0; - } + for (;;) + { + /* No two fields will ever point to the same map type unless they are + the same component, because one map field is created with its type + declaration. Therefore don't worry about recursion here. */ + /* TODO: worry about recursion into parent types of the unions? */ + if (!compare_components (cmp1, cmp2, map1_t, map2_t)) + return false; - return 1; + cmp1 = cmp1->next; + cmp2 = cmp2->next; + + if (cmp1 == NULL && cmp2 == NULL) + break; + if (cmp1 == NULL || cmp2 == NULL) + return false; + } + + map1 = map1->next; + map2 = map2->next; + + if (map1 == NULL && map2 == NULL) + break; + if (map1 == NULL || map2 == NULL) + return false; + } + + return true; } @@ -508,25 +607,20 @@ gfc_compare_union_types (gfc_symbol *un1, gfc_symbol *un2) /* Compare two derived types using the criteria in 4.4.2 of the standard, recursing through gfc_compare_types for the components. */ -int +bool gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) { gfc_component *cmp1, *cmp2; - bool anonymous = false; if (derived1 == derived2) - return 1; + return true; - gcc_assert (derived1 && derived2); + if (!derived1 || !derived2) + gfc_internal_error ("gfc_compare_derived_types: invalid derived type"); - /* MAP and anonymous STRUCTURE types have internal names of the form - mM* and sS* (we can get away this this because source names are converted - to lowerase). Compare anonymous type names specially because each - gets a unique name when it is declared. */ - anonymous = (derived1->name[0] == derived2->name[0] - && derived1->name[1] && derived2->name[1] && derived2->name[2] - && derived1->name[1] == (char) TOUPPER (derived1->name[0]) - && derived2->name[2] == (char) TOUPPER (derived2->name[0])); + /* Compare UNION types specially. */ + if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION) + return compare_union_types (derived1, derived2); /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is @@ -534,30 +628,32 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) if (strcmp (derived1->name, derived2->name) == 0 && derived1->module != NULL && derived2->module != NULL && strcmp (derived1->module, derived2->module) == 0) - return 1; + return true; /* Compare type via the rules of the standard. Both types must have the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special because they can be anonymous; therefore two structures with different names may be equal. */ - if (strcmp (derived1->name, derived2->name) != 0 && !anonymous) - return 0; + /* Compare names, but not for anonymous types such as UNION or MAP. */ + if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) + && strcmp (derived1->name, derived2->name) != 0) + return false; if (derived1->component_access == ACCESS_PRIVATE || derived2->component_access == ACCESS_PRIVATE) - return 0; + return false; if (!(derived1->attr.sequence && derived2->attr.sequence) && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c)) - return 0; + return false; /* Protect against null components. */ if (derived1->attr.zero_comp != derived2->attr.zero_comp) - return 0; + return false; if (derived1->attr.zero_comp) - return 1; + return true; cmp1 = derived1->components; cmp2 = derived2->components; @@ -568,7 +664,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) for (;;) { if (!compare_components (cmp1, cmp2, derived1, derived2)) - return 0; + return false; cmp1 = cmp1->next; cmp2 = cmp2->next; @@ -576,16 +672,16 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) if (cmp1 == NULL && cmp2 == NULL) break; if (cmp1 == NULL || cmp2 == NULL) - return 0; + return false; } - return 1; + return true; } /* Compare two typespecs, recursively if necessary. */ -int +bool gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) { /* See if one of the typespecs is a BT_VOID, which is what is being used @@ -593,7 +689,7 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) TODO: Possibly should narrow this to just the one typespec coming in that is for the formal arg, but oh well. */ if (ts1->type == BT_VOID || ts2->type == BT_VOID) - return 1; + return true; /* The _data component is not always present, therefore check for its presence before assuming, that its derived->attr is available. @@ -604,7 +700,7 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) && ts1->u.derived->components->ts.u.derived->attr .unlimited_polymorphic) || ts1->u.derived->attr.unlimited_polymorphic)) - return 1; + return true; /* F2003: C717 */ if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED @@ -614,15 +710,16 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) .unlimited_polymorphic) || ts2->u.derived->attr.unlimited_polymorphic) && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) - return 1; - - if (ts1->type == BT_UNION && ts2->type == BT_UNION) - return gfc_compare_union_types (ts1->u.derived, ts2->u.derived); + return true; if (ts1->type != ts2->type - && ((!gfc_bt_struct (ts1->type) && ts1->type != BT_CLASS) - || (!gfc_bt_struct (ts2->type) && ts2->type != BT_CLASS))) - return 0; + && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) + || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) + return false; + + if (ts1->type == BT_UNION) + return compare_union_types (ts1->u.derived, ts2->u.derived); + if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) return (ts1->kind == ts2->kind); @@ -631,30 +728,30 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) } -static int +static bool compare_type (gfc_symbol *s1, gfc_symbol *s2) { if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return 1; + return true; /* TYPE and CLASS of the same declared type are type compatible, but have different characteristics. */ if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) - return 0; + return false; return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; } -static int +static bool compare_rank (gfc_symbol *s1, gfc_symbol *s2) { gfc_array_spec *as1, *as2; int r1, r2; if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return 1; + return true; as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as; as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as; @@ -663,17 +760,17 @@ compare_rank (gfc_symbol *s1, gfc_symbol *s2) r2 = as2 ? as2->rank : 0; if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) - return 0; /* Ranks differ. */ + return false; /* Ranks differ. */ - return 1; + return true; } /* Given two symbols that are formal arguments, compare their ranks - and types. Returns nonzero if they have the same rank and type, - zero otherwise. */ + and types. Returns true if they have the same rank and type, + false otherwise. */ -static int +static bool compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) { return compare_type (s1, s2) && compare_rank (s1, s2); @@ -682,44 +779,44 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) /* Given two symbols that are formal arguments, compare their types and rank and their formal interfaces if they are both dummy - procedures. Returns nonzero if the same, zero if different. */ + procedures. Returns true if the same, false if different. */ -static int +static bool compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2) { if (s1 == NULL || s2 == NULL) - return s1 == s2 ? 1 : 0; + return (s1 == s2); if (s1 == s2) - return 1; + return true; if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) return compare_type_rank (s1, s2); if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) - return 0; + return false; /* At this point, both symbols are procedures. It can happen that external procedures are compared, where one is identified by usage to be a function or subroutine but the other is not. Check TKR nonetheless for these cases. */ if (s1->attr.function == 0 && s1->attr.subroutine == 0) - return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0; + return s1->attr.external ? compare_type_rank (s1, s2) : false; if (s2->attr.function == 0 && s2->attr.subroutine == 0) - return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0; + return s2->attr.external ? compare_type_rank (s1, s2) : false; /* Now the type of procedure has been identified. */ if (s1->attr.function != s2->attr.function || s1->attr.subroutine != s2->attr.subroutine) - return 0; + return false; - if (s1->attr.function && compare_type_rank (s1, s2) == 0) - return 0; + if (s1->attr.function && !compare_type_rank (s1, s2)) + return false; /* Originally, gfortran recursed here to check the interfaces of passed procedures. This is explicitly not required by the standard. */ - return 1; + return true; } @@ -992,11 +1089,11 @@ bad_repl: by this test. This subroutine implements rule 1 of section F03:16.2.3. 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ -static int +static bool count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, const char *p1, const char *p2) { - int rc, ac1, ac2, i, j, k, n1; + int ac1, ac2, i, j, k, n1; gfc_formal_arglist *f; typedef struct @@ -1051,7 +1148,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, /* Now loop over each distinct type found in f1. */ k = 0; - rc = 0; + bool rc = false; for (i = 0; i < n1; i++) { @@ -1075,7 +1172,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, if (ac1 > ac2) { - rc = 1; + rc = true; break; } @@ -1109,7 +1206,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ -static int +static bool generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, const char *p1, const char *p2) { @@ -1147,7 +1244,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, || ((gfc_option.allow_std & GFC_STD_F2008) && ((sym->attr.allocatable && g->sym->attr.pointer) || (sym->attr.pointer && g->sym->attr.allocatable)))) - return 1; + return true; } next: @@ -1157,7 +1254,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, f2 = f2->next; } - return 0; + return false; } @@ -1541,13 +1638,13 @@ gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, /* 'Compare' two formal interfaces associated with a pair of symbols. - We return nonzero if there exists an actual argument list that + We return true if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. 'strict_flag' specifies whether all the characteristics are required to match, which is not the case for ambiguity checks. 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ -int +bool gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, int generic_flag, int strict_flag, char *errmsg, int err_len, @@ -1563,14 +1660,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' is not a function", name2); - return 0; + return false; } if (s1->attr.subroutine && s2->attr.function) { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); - return 0; + return false; } /* Do strict checks on all characteristics @@ -1582,39 +1679,48 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, /* If both are functions, check result characteristics. */ if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len) || !gfc_check_result_characteristics (s2, s1, errmsg, err_len)) - return 0; + return false; } if (s1->attr.pure && !s2->attr.pure) { snprintf (errmsg, err_len, "Mismatch in PURE attribute"); - return 0; + return false; } if (s1->attr.elemental && !s2->attr.elemental) { snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute"); - return 0; + return false; } } if (s1->attr.if_source == IFSRC_UNKNOWN || s2->attr.if_source == IFSRC_UNKNOWN) - return 1; + return true; f1 = gfc_sym_get_dummy_args (s1); f2 = gfc_sym_get_dummy_args (s2); + /* Special case: No arguments. */ if (f1 == NULL && f2 == NULL) - return 1; /* Special case: No arguments. */ + return true; if (generic_flag) { if (count_types_test (f1, f2, p1, p2) || count_types_test (f2, f1, p2, p1)) - return 0; + return false; + + /* Special case: alternate returns. If both f1->sym and f2->sym are + NULL, then the leading formal arguments are alternate returns. + The previous conditional should catch argument lists with + different number of argument. */ + if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) + return true; + if (generic_correspondence (f1, f2, p1, p2) || generic_correspondence (f2, f1, p2, p1)) - return 0; + return false; } else /* Perform the abbreviated correspondence test for operators (the @@ -1622,28 +1728,23 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, This is also done when comparing interfaces for dummy procedures and in procedure pointer assignments. */ - for (;;) + for (; f1 || f2; f1 = f1->next, f2 = f2->next) { /* Check existence. */ - if (f1 == NULL && f2 == NULL) - break; if (f1 == NULL || f2 == NULL) { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' has the wrong number of " "arguments", name2); - return 0; + return false; } - if (UNLIMITED_POLY (f1->sym)) - goto next; - if (strict_flag) { /* Check all characteristics. */ if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true, errmsg, err_len)) - return 0; + return false; } else { @@ -1655,7 +1756,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, "(%s/%s)", f1->sym->name, gfc_typename (&f1->sym->ts), gfc_typename (&f2->sym->ts)); - return 0; + return false; } if (!compare_rank (f2->sym, f1->sym)) { @@ -1663,24 +1764,21 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, snprintf (errmsg, err_len, "Rank mismatch in argument '%s' " "(%i/%i)", f1->sym->name, symbol_rank (f1->sym), symbol_rank (f2->sym)); - return 0; + return false; } } -next: - f1 = f1->next; - f2 = f2->next; } - return 1; + return true; } /* Given a pointer to an interface pointer, remove duplicate interfaces and make sure that all symbols are either functions - or subroutines, and all of the same kind. Returns nonzero if + or subroutines, and all of the same kind. Returns true if something goes wrong. */ -static int +static bool check_interface0 (gfc_interface *p, const char *interface_name) { gfc_interface *psave, *q, *qlast; @@ -1701,7 +1799,7 @@ check_interface0 (gfc_interface *p, const char *interface_name) gfc_error ("Procedure %qs in %s at %L is neither function nor " "subroutine", p->sym->name, interface_name, &p->sym->declared_at); - return 1; + return true; } /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ @@ -1717,7 +1815,7 @@ check_interface0 (gfc_interface *p, const char *interface_name) gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " "generic name is also the name of a derived type", interface_name, &p->sym->declared_at); - return 1; + return true; } /* F2003, C1207. F2008, C1207. */ @@ -1725,7 +1823,7 @@ check_interface0 (gfc_interface *p, const char *interface_name) && !gfc_notify_std (GFC_STD_F2008, "Internal procedure " "%qs in %s at %L", p->sym->name, interface_name, &p->sym->declared_at)) - return 1; + return true; } p = psave; @@ -1751,14 +1849,14 @@ check_interface0 (gfc_interface *p, const char *interface_name) } } - return 0; + return false; } /* Check lists of interfaces to make sure that no two interfaces are ambiguous. Duplicate interfaces (from the same symbol) are OK here. */ -static int +static bool check_interface1 (gfc_interface *p, gfc_interface *q0, int generic_flag, const char *interface_name, bool referenced) @@ -1779,20 +1877,22 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, generic_flag, 0, NULL, 0, NULL, NULL)) { if (referenced) - gfc_error ("Ambiguous interfaces %qs and %qs in %s at %L", - p->sym->name, q->sym->name, interface_name, - &p->where); + gfc_error ("Ambiguous interfaces in %s for %qs at %L " + "and %qs at %L", interface_name, + q->sym->name, &q->sym->declared_at, + p->sym->name, &p->sym->declared_at); else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) - gfc_warning (0, "Ambiguous interfaces %qs and %qs in %s at %L", - p->sym->name, q->sym->name, interface_name, - &p->where); + gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L " + "and %qs at %L", interface_name, + q->sym->name, &q->sym->declared_at, + p->sym->name, &p->sym->declared_at); else gfc_warning (0, "Although not referenced, %qs has ambiguous " "interfaces at %L", interface_name, &p->where); - return 1; + return true; } } - return 0; + return false; } @@ -1970,22 +2070,22 @@ done: /* Given a symbol of a formal argument list and an expression, if the formal argument is allocatable, check that the actual argument is - allocatable. Returns nonzero if compatible, zero if not compatible. */ + allocatable. Returns true if compatible, zero if not compatible. */ -static int +static bool compare_allocatable (gfc_symbol *formal, gfc_expr *actual) { - symbol_attribute attr; - if (formal->attr.allocatable || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) { - attr = gfc_expr_attr (actual); - if (!attr.allocatable) - return 0; + symbol_attribute attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !attr.class_ok) + return true; + else if (!attr.allocatable) + return false; } - return 1; + return true; } @@ -2025,33 +2125,25 @@ argument_rank_mismatch (const char *name, locus *where, /* TS 29113, C407b. */ if (rank2 == -1) - { - gfc_error ("The assumed-rank array at %L requires that the dummy argument" - " %qs has assumed-rank", where, name); - } + gfc_error ("The assumed-rank array at %L requires that the dummy argument" + " %qs has assumed-rank", where, name); else if (rank1 == 0) - { - gfc_error ("Rank mismatch in argument %qs at %L " - "(scalar and rank-%d)", name, where, rank2); - } + gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " + "at %L (scalar and rank-%d)", name, where, rank2); else if (rank2 == 0) - { - gfc_error ("Rank mismatch in argument %qs at %L " - "(rank-%d and scalar)", name, where, rank1); - } + gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " + "at %L (rank-%d and scalar)", name, where, rank1); else - { - gfc_error ("Rank mismatch in argument %qs at %L " - "(rank-%d and rank-%d)", name, where, rank1, rank2); - } + gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs " + "at %L (rank-%d and rank-%d)", name, where, rank1, rank2); } /* Given a symbol of a formal argument list and an expression, see if - the two are compatible as arguments. Returns nonzero if - compatible, zero if not compatible. */ + the two are compatible as arguments. Returns true if + compatible, false if not compatible. */ -static int +static bool compare_parameter (gfc_symbol *formal, gfc_expr *actual, int ranks_must_agree, int is_elemental, locus *where) { @@ -2064,13 +2156,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, procs c_f_pointer or c_f_procpointer, and we need to accept most pointers the user could give us. This should allow that. */ if (formal->ts.type == BT_VOID) - return 1; + return true; if (formal->ts.type == BT_DERIVED && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c && actual->ts.type == BT_DERIVED && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) - return 1; + return true; if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when @@ -2085,16 +2177,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) gfc_error ("Invalid procedure argument at %L", &actual->where); - return 0; + return false; } if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, sizeof(err), NULL, NULL)) { if (where) - gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", - formal->name, &actual->where, err); - return 0; + gfc_error_opt (OPT_Wargument_mismatch, + "Interface mismatch in dummy procedure %qs at %L:" + " %s", formal->name, &actual->where, err); + return false; } if (formal->attr.function && !act_sym->attr.function) @@ -2103,13 +2196,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, &act_sym->declared_at); if (act_sym->ts.type == BT_UNKNOWN && !gfc_set_default_type (act_sym, 1, act_sym->ns)) - return 0; + return false; } else if (formal->attr.subroutine && !act_sym->attr.subroutine) gfc_add_subroutine (&act_sym->attr, act_sym->name, &act_sym->declared_at); - return 1; + return true; } ppc = gfc_get_proc_ptr_comp (actual); @@ -2119,9 +2212,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, err, sizeof(err), NULL, NULL)) { if (where) - gfc_error ("Interface mismatch in dummy procedure %qs at %L: %s", - formal->name, &actual->where, err); - return 0; + gfc_error_opt (OPT_Wargument_mismatch, + "Interface mismatch in dummy procedure %qs at %L:" + " %s", formal->name, &actual->where, err); + return false; } } @@ -2132,9 +2226,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " "must be simply contiguous", formal->name, &actual->where); - return 0; + return false; } + symbol_attribute actual_attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !actual_attr.class_ok) + return true; + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH && formal->ts.type != BT_ASSUMED @@ -2145,10 +2243,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, CLASS_DATA (actual)->ts.u.derived))) { if (where) - gfc_error ("Type mismatch in argument %qs at %L; passed %s to %s", - formal->name, &actual->where, gfc_typename (&actual->ts), - gfc_typename (&formal->ts)); - return 0; + gfc_error_opt (OPT_Wargument_mismatch, + "Type mismatch in argument %qs at %L; passed %s to %s", + formal->name, where, gfc_typename (&actual->ts), + gfc_typename (&formal->ts)); + return false; } if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) @@ -2157,7 +2256,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Assumed-type actual argument at %L requires that dummy " "argument %qs is of assumed type", &actual->where, formal->name); - return 0; + return false; } /* F2008, 12.5.2.5; IR F08/0073. */ @@ -2172,12 +2271,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Actual argument to %qs at %L must be polymorphic", formal->name, &actual->where); - return 0; + return false; } - if (!gfc_expr_attr (actual).class_ok) - return 0; - if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, CLASS_DATA (formal)->ts.u.derived)) @@ -2185,7 +2281,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Actual argument to %qs at %L must have the same " "declared type", formal->name, &actual->where); - return 0; + return false; } } @@ -2203,7 +2299,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, "pointer or allocatable unlimited polymorphic " "entity [F2008: 12.5.2.5]", formal->name, &actual->where); - return 0; + return false; } if (formal->attr.codimension && !gfc_is_coarray (actual)) @@ -2211,7 +2307,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Actual argument to %qs at %L must be a coarray", formal->name, &actual->where); - return 0; + return false; } if (formal->attr.codimension && formal->attr.allocatable) @@ -2232,7 +2328,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, formal->name, &actual->where, formal->as->corank, last ? last->u.c.component->as->corank : actual->symtree->n.sym->as->corank); - return 0; + return false; } } @@ -2242,14 +2338,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, /* F2015, 12.5.2.8. */ if (formal->attr.dimension && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) - && gfc_expr_attr (actual).dimension + && actual_attr.dimension && !gfc_is_simply_contiguous (actual, true, true)) { if (where) gfc_error ("Actual argument to %qs at %L must be simply " "contiguous or an element of such an array", formal->name, &actual->where); - return 0; + return false; } /* F2008, C1303 and C1304. */ @@ -2264,7 +2360,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " "which is LOCK_TYPE or has a LOCK_TYPE component", formal->name, &actual->where); - return 0; + return false; } /* TS18508, C702/C703. */ @@ -2279,7 +2375,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " "which is EVENT_TYPE or has a EVENT_TYPE component", formal->name, &actual->where); - return 0; + return false; } } @@ -2299,11 +2395,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, "assumed-rank array without CONTIGUOUS attribute - as actual" " argument at %L is not simply contiguous and both are " "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); - return 0; + return false; } if (formal->attr.allocatable && !formal->attr.codimension - && gfc_expr_attr (actual).codimension) + && actual_attr.codimension) { if (formal->attr.intent == INTENT_OUT) { @@ -2311,7 +2407,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Passing coarray at %L to allocatable, noncoarray, " "INTENT(OUT) dummy argument %qs", &actual->where, formal->name); - return 0; + return false; } else if (warn_surprising && where && formal->attr.intent != INTENT_IN) gfc_warning (OPT_Wsurprising, @@ -2322,7 +2418,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, /* If the rank is the same or the formal argument has assumed-rank. */ if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) - return 1; + return true; rank_check = where != NULL && !is_elemental && formal->as && (formal->as->type == AS_ASSUMED_SHAPE @@ -2331,7 +2427,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, /* Skip rank checks for NO_ARG_CHECK. */ if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return 1; + return true; /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ if (rank_check || ranks_must_agree @@ -2349,10 +2445,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) argument_rank_mismatch (formal->name, &actual->where, symbol_rank (formal), actual->rank); - return 0; + return false; } else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) - return 1; + return true; /* At this point, we are considering a scalar passed to an array. This is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), @@ -2380,7 +2476,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) gfc_error ("Polymorphic scalar passed to array dummy argument %qs " "at %L", formal->name, &actual->where); - return 0; + return false; } if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER @@ -2390,7 +2486,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Element of assumed-shaped or pointer " "array passed to array dummy argument %qs at %L", formal->name, &actual->where); - return 0; + return false; } if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL @@ -2402,7 +2498,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " "CHARACTER actual argument with array dummy argument " "%qs at %L", formal->name, &actual->where); - return 0; + return false; } if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) @@ -2410,12 +2506,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " "array dummy argument %qs at %L", formal->name, &actual->where); - return 0; + return false; } - else if ((gfc_option.allow_std & GFC_STD_F2003) == 0) - return 0; else - return 1; + return ((gfc_option.allow_std & GFC_STD_F2003) != 0); } if (ref == NULL && actual->expr_type != EXPR_NULL) @@ -2423,10 +2517,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (where) argument_rank_mismatch (formal->name, &actual->where, symbol_rank (formal), actual->rank); - return 0; + return false; } - return 1; + return true; } @@ -2650,25 +2744,24 @@ get_expr_storage_size (gfc_expr *e) /* Given an expression, check whether it is an array section - which has a vector subscript. If it has, one is returned, - otherwise zero. */ + which has a vector subscript. */ -int +bool gfc_has_vector_subscript (gfc_expr *e) { int i; gfc_ref *ref; if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) - return 0; + return false; for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) for (i = 0; i < ref->u.ar.dimen; i++) if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - return 1; + return true; - return 0; + return false; } @@ -2691,7 +2784,7 @@ is_procptr_result (gfc_expr *expr) errors when things don't match instead of just returning the status code. */ -static int +static bool compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, int ranks_must_agree, int is_elemental, locus *where) { @@ -2700,11 +2793,12 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, int i, n, na; unsigned long actual_size, formal_size; bool full_array = false; + gfc_array_ref *actual_arr_ref; actual = *ap; if (actual == NULL && formal == NULL) - return 1; + return true; n = 0; for (f = formal; f; f = f->next) @@ -2738,7 +2832,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Keyword argument %qs at %L is not in " "the procedure", a->name, &a->expr->where); - return 0; + return false; } if (new_arg[i] != NULL) @@ -2747,7 +2841,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Keyword argument %qs at %L is already associated " "with another actual argument", a->name, &a->expr->where); - return 0; + return false; } } @@ -2757,7 +2851,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("More actual than formal arguments in procedure " "call at %L", where); - return 0; + return false; } if (f->sym == NULL && a->expr == NULL) @@ -2768,7 +2862,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Missing alternate return spec in subroutine call " "at %L", where); - return 0; + return false; } if (a->expr == NULL) @@ -2776,7 +2870,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Unexpected alternate return spec in subroutine " "call at %L", where); - return 0; + return false; } /* Make sure that intrinsic vtables exist for calls to unlimited @@ -2807,12 +2901,12 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " "dummy %qs", where, f->sym->name); - return 0; + return false; } if (!compare_parameter (f->sym, a->expr, ranks_must_agree, is_elemental, where)) - return 0; + return false; /* TS 29113, 6.3p2. */ if (f->sym->ts.type == BT_ASSUMED @@ -2839,44 +2933,45 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, and assumed-shape dummies, the string length needs to match exactly. */ if (a->expr->ts.type == BT_CHARACTER - && a->expr->ts.u.cl && a->expr->ts.u.cl->length - && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT - && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length - && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT - && (f->sym->attr.pointer || f->sym->attr.allocatable - || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) - && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, - f->sym->ts.u.cl->length->value.integer) != 0)) - { - if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (0, - "Character length mismatch (%ld/%ld) between actual " - "argument and pointer or allocatable dummy argument " - "%qs at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - else if (where) - gfc_warning (0, - "Character length mismatch (%ld/%ld) between actual " - "argument and assumed-shape dummy argument %qs " - "at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - return 0; - } + && a->expr->ts.u.cl && a->expr->ts.u.cl->length + && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl + && f->sym->ts.u.cl->length + && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && (f->sym->attr.pointer || f->sym->attr.allocatable + || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) + && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, + f->sym->ts.u.cl->length->value.integer) != 0)) + { + if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) + gfc_warning (OPT_Wargument_mismatch, + "Character length mismatch (%ld/%ld) between actual " + "argument and pointer or allocatable dummy argument " + "%qs at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + else if (where) + gfc_warning (OPT_Wargument_mismatch, + "Character length mismatch (%ld/%ld) between actual " + "argument and assumed-shape dummy argument %qs " + "at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + return false; + } if ((f->sym->attr.pointer || f->sym->attr.allocatable) - && f->sym->ts.deferred != a->expr->ts.deferred - && a->expr->ts.type == BT_CHARACTER) + && f->sym->ts.deferred != a->expr->ts.deferred + && a->expr->ts.type == BT_CHARACTER) { if (where) gfc_error ("Actual argument at %L to allocatable or " "pointer dummy argument %qs must have a deferred " "length type parameter if and only if the dummy has one", &a->expr->where, f->sym->name); - return 0; + return false; } if (f->sym->ts.type == BT_CLASS) @@ -2889,16 +2984,18 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && f->sym->attr.flavor != FL_PROCEDURE) { if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) - gfc_warning (0, "Character length of actual argument shorter " + gfc_warning (OPT_Wargument_mismatch, + "Character length of actual argument shorter " "than of dummy argument %qs (%lu/%lu) at %L", f->sym->name, actual_size, formal_size, &a->expr->where); else if (where) - gfc_warning (0, "Actual argument contains too few " + gfc_warning (OPT_Wargument_mismatch, + "Actual argument contains too few " "elements for dummy argument %qs (%lu/%lu) at %L", f->sym->name, actual_size, formal_size, &a->expr->where); - return 0; + return false; } skip_size_check: @@ -2915,7 +3012,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Expected a procedure pointer for argument %qs at %L", f->sym->name, &a->expr->where); - return 0; + return false; } /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is @@ -2931,7 +3028,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Expected a procedure for argument %qs at %L", f->sym->name, &a->expr->where); - return 0; + return false; } if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE @@ -2945,7 +3042,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Actual argument for %qs cannot be an assumed-size" " array at %L", f->sym->name, where); - return 0; + return false; } if (a->expr->expr_type != EXPR_NULL @@ -2954,7 +3051,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Actual argument for %qs must be a pointer at %L", f->sym->name, &a->expr->where); - return 0; + return false; } if (a->expr->expr_type != EXPR_NULL @@ -2964,7 +3061,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " "pointer dummy %qs", &a->expr->where,f->sym->name); - return 0; + return false; } @@ -2975,7 +3072,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Coindexed actual argument at %L to pointer " "dummy %qs", &a->expr->where, f->sym->name); - return 0; + return false; } /* Fortran 2008, 12.5.2.5 (no constraint). */ @@ -2988,7 +3085,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Coindexed actual argument at %L to allocatable " "dummy %qs requires INTENT(IN)", &a->expr->where, f->sym->name); - return 0; + return false; } /* Fortran 2008, C1237. */ @@ -3003,7 +3100,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "%L requires that dummy %qs has neither " "ASYNCHRONOUS nor VOLATILE", &a->expr->where, f->sym->name); - return 0; + return false; } /* Fortran 2008, 12.5.2.4 (no constraint). */ @@ -3016,7 +3113,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_error ("Coindexed actual argument at %L with allocatable " "ultimate component to dummy %qs requires either VALUE " "or INTENT(IN)", &a->expr->where, f->sym->name); - return 0; + return false; } if (f->sym->ts.type == BT_CLASS @@ -3027,17 +3124,17 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Actual CLASS array argument for %qs must be a full " "array at %L", f->sym->name, &a->expr->where); - return 0; + return false; } if (a->expr->expr_type != EXPR_NULL - && compare_allocatable (f->sym, a->expr) == 0) + && !compare_allocatable (f->sym, a->expr)) { if (where) gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", f->sym->name, &a->expr->where); - return 0; + return false; } /* Check intent = OUT/INOUT for definable actual argument. */ @@ -3052,9 +3149,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && CLASS_DATA (f->sym)->attr.class_pointer) || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) && !gfc_check_vardef_context (a->expr, true, false, false, context)) - return 0; + return false; if (!gfc_check_vardef_context (a->expr, false, false, false, context)) - return 0; + return false; } if ((f->sym->attr.intent == INTENT_OUT @@ -3069,7 +3166,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " "of the dummy argument %qs", &a->expr->where, f->sym->name); - return 0; + return false; } /* C1232 (R1221) For an actual argument which is an array section or @@ -3077,6 +3174,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, shape array, if the dummy argument has the VOLATILE attribute. */ if (f->sym->attr.volatile_ + && a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym->as && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) @@ -3086,19 +3184,24 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "incompatible with the non-assumed-shape " "dummy argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); - return 0; + return false; } + /* Find the last array_ref. */ + actual_arr_ref = NULL; + if (a->expr->ref) + actual_arr_ref = gfc_find_array_ref (a->expr, true); + if (f->sym->attr.volatile_ - && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION + && actual_arr_ref && actual_arr_ref->type == AR_SECTION && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) { if (where) gfc_error ("Array-section actual argument at %L is " "incompatible with the non-assumed-shape " "dummy argument %qs due to VOLATILE attribute", - &a->expr->where,f->sym->name); - return 0; + &a->expr->where, f->sym->name); + return false; } /* C1233 (R1221) For an actual argument which is a pointer array, the @@ -3106,6 +3209,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, dummy argument has the VOLATILE attribute. */ if (f->sym->attr.volatile_ + && a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym->attr.pointer && a->expr->symtree->n.sym->as && !(f->sym->as @@ -3117,7 +3221,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, "an assumed-shape or pointer-array dummy " "argument %qs due to VOLATILE attribute", &a->expr->where,f->sym->name); - return 0; + return false; } match: @@ -3138,14 +3242,14 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (where) gfc_error ("Missing alternate return spec in subroutine call " "at %L", where); - return 0; + return false; } if (!f->sym->attr.optional) { if (where) gfc_error ("Missing actual argument for argument %qs at %L", f->sym->name, where); - return 0; + return false; } } @@ -3175,7 +3279,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (a->expr == NULL && a->label == NULL) a->missing_arg_type = f->sym->ts.type; - return 1; + return true; } @@ -3770,7 +3874,7 @@ matching_typebound_op (gfc_expr** tb_base, if (base->expr->ts.type == BT_CLASS) { - if (CLASS_DATA (base->expr) == NULL + if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL || !gfc_expr_attr (base->expr).class_ok) continue; derived = CLASS_DATA (base->expr)->ts.u.derived; @@ -3945,7 +4049,7 @@ gfc_extend_expr (gfc_expr *e) else return MATCH_YES; } - + if (i == INTRINSIC_USER) { for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -4136,60 +4240,60 @@ gfc_add_interface (gfc_symbol *new_sym) { case INTRINSIC_EQ: case INTRINSIC_EQ_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, + if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym, gfc_current_locus)) return false; break; case INTRINSIC_NE: case INTRINSIC_NE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, + if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym, gfc_current_locus)) return false; break; case INTRINSIC_GT: case INTRINSIC_GT_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], + if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym, gfc_current_locus)) return false; break; case INTRINSIC_GE: case INTRINSIC_GE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], + if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym, gfc_current_locus)) return false; break; case INTRINSIC_LT: case INTRINSIC_LT_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], + if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym, gfc_current_locus)) return false; break; case INTRINSIC_LE: case INTRINSIC_LE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], + if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], + || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym, gfc_current_locus)) return false; break; default: - if (!gfc_check_new_interface (ns->op[current_interface.op], + if (!gfc_check_new_interface (ns->op[current_interface.op], new_sym, gfc_current_locus)) return false; } @@ -4198,13 +4302,14 @@ gfc_add_interface (gfc_symbol *new_sym) break; case INTERFACE_GENERIC: + case INTERFACE_DTIO: for (ns = current_interface.ns; ns; ns = ns->parent) { gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); if (sym == NULL) continue; - if (!gfc_check_new_interface (sym->generic, + if (!gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)) return false; } @@ -4213,7 +4318,7 @@ gfc_add_interface (gfc_symbol *new_sym) break; case INTERFACE_USER_OP: - if (!gfc_check_new_interface (current_interface.uop->op, + if (!gfc_check_new_interface (current_interface.uop->op, new_sym, gfc_current_locus)) return false; @@ -4242,15 +4347,13 @@ gfc_current_interface_head (void) { case INTERFACE_INTRINSIC_OP: return current_interface.ns->op[current_interface.op]; - break; case INTERFACE_GENERIC: + case INTERFACE_DTIO: return current_interface.sym->generic; - break; case INTERFACE_USER_OP: return current_interface.uop->op; - break; default: gcc_unreachable (); @@ -4268,6 +4371,7 @@ gfc_set_current_interface_head (gfc_interface *i) break; case INTERFACE_GENERIC: + case INTERFACE_DTIO: current_interface.sym->generic = i; break; @@ -4439,8 +4543,9 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, check_type, err, sizeof(err))) { - gfc_error ("Argument mismatch for the overriding procedure " - "%qs at %L: %s", proc->name, &where, err); + gfc_error_opt (OPT_Wargument_mismatch, + "Argument mismatch for the overriding procedure " + "%qs at %L: %s", proc->name, &where, err); return false; } @@ -4484,3 +4589,379 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) return true; } + + +/* The following three functions check that the formal arguments + of user defined derived type IO procedures are compliant with + the requirements of the standard. */ + +static void +check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, + int kind, int rank, sym_intent intent) +{ + if (fsym->ts.type != type) + { + gfc_error ("DTIO dummy argument at %L must be of type %s", + &fsym->declared_at, gfc_basic_typename (type)); + return; + } + + if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED + && fsym->ts.kind != kind) + gfc_error ("DTIO dummy argument at %L must be of KIND = %d", + &fsym->declared_at, kind); + + if (!typebound + && rank == 0 + && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension) + || ((type != BT_CLASS) && fsym->attr.dimension))) + gfc_error ("DTIO dummy argument at %L must be a scalar", + &fsym->declared_at); + else if (rank == 1 + && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) + gfc_error ("DTIO dummy argument at %L must be an " + "ASSUMED SHAPE ARRAY", &fsym->declared_at); + + if (fsym->attr.intent != intent) + gfc_error ("DTIO dummy argument at %L must have INTENT %s", + &fsym->declared_at, gfc_code2string (intents, (int)intent)); + return; +} + + +static void +check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, + bool typebound, bool formatted, int code) +{ + gfc_symbol *dtio_sub, *generic_proc, *fsym; + gfc_typebound_proc *tb_io_proc, *specific_proc; + gfc_interface *intr; + gfc_formal_arglist *formal; + int arg_num; + + bool read = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_RUF); + bt type; + sym_intent intent; + int kind; + + dtio_sub = NULL; + if (typebound) + { + /* Typebound DTIO binding. */ + tb_io_proc = tb_io_st->n.tb; + if (tb_io_proc == NULL) + return; + + gcc_assert (tb_io_proc->is_generic); + gcc_assert (tb_io_proc->u.generic->next == NULL); + + specific_proc = tb_io_proc->u.generic->specific; + if (specific_proc == NULL || specific_proc->is_generic) + return; + + dtio_sub = specific_proc->u.specific->n.sym; + } + else + { + generic_proc = tb_io_st->n.sym; + if (generic_proc == NULL || generic_proc->generic == NULL) + return; + + for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) + { + if (intr->sym && intr->sym->formal && intr->sym->formal->sym + && ((intr->sym->formal->sym->ts.type == BT_CLASS + && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived + == derived) + || (intr->sym->formal->sym->ts.type == BT_DERIVED + && intr->sym->formal->sym->ts.u.derived == derived))) + { + dtio_sub = intr->sym; + break; + } + else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym) + { + gfc_error ("Alternate return at %L is not permitted in a DTIO " + "procedure", &intr->sym->declared_at); + return; + } + } + + if (dtio_sub == NULL) + return; + } + + gcc_assert (dtio_sub); + if (!dtio_sub->attr.subroutine) + gfc_error ("DTIO procedure %qs at %L must be a subroutine", + dtio_sub->name, &dtio_sub->declared_at); + + arg_num = 0; + for (formal = dtio_sub->formal; formal; formal = formal->next) + arg_num++; + + if (arg_num < (formatted ? 6 : 4)) + { + gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L", + dtio_sub->name, &dtio_sub->declared_at); + return; + } + + if (arg_num > (formatted ? 6 : 4)) + { + gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L", + dtio_sub->name, &dtio_sub->declared_at); + return; + } + + + /* Now go through the formal arglist. */ + arg_num = 1; + for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) + { + if (!formatted && arg_num == 3) + arg_num = 5; + fsym = formal->sym; + + if (fsym == NULL) + { + gfc_error ("Alternate return at %L is not permitted in a DTIO " + "procedure", &dtio_sub->declared_at); + return; + } + + switch (arg_num) + { + case(1): /* DTV */ + type = derived->attr.sequence || derived->attr.is_bind_c ? + BT_DERIVED : BT_CLASS; + kind = 0; + intent = read ? INTENT_INOUT : INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + + case(2): /* UNIT */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(3): /* IOTYPE */ + type = BT_CHARACTER; + kind = gfc_default_character_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(4): /* VLIST */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 1, intent); + break; + case(5): /* IOSTAT */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_OUT; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(6): /* IOMSG */ + type = BT_CHARACTER; + kind = gfc_default_character_kind; + intent = INTENT_INOUT; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + default: + gcc_unreachable (); + } + } + derived->attr.has_dtio_procs = 1; + return; +} + +void +gfc_check_dtio_interfaces (gfc_symbol *derived) +{ + gfc_symtree *tb_io_st; + bool t = false; + int code; + bool formatted; + + if (derived->attr.is_class == 1 || derived->attr.vtype == 1) + return; + + /* Check typebound DTIO bindings. */ + for (code = 0; code < 4; code++) + { + formatted = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_WF); + + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, code), + true, &derived->declared_at); + if (tb_io_st != NULL) + check_dtio_interface1 (derived, tb_io_st, true, formatted, code); + } + + /* Check generic DTIO interfaces. */ + for (code = 0; code < 4; code++) + { + formatted = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_WF); + + tb_io_st = gfc_find_symtree (derived->ns->sym_root, + gfc_code2string (dtio_procs, code)); + if (tb_io_st != NULL) + check_dtio_interface1 (derived, tb_io_st, false, formatted, code); + } +} + + +gfc_symtree* +gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + bool t = false; + + if (!derived || !derived->resolved || derived->attr.flavor != FL_DERIVED) + return NULL; + + /* Try to find a typebound DTIO binding. */ + if (formatted == true) + { + if (write == true) + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_WF), + true, + &derived->declared_at); + else + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_RF), + true, + &derived->declared_at); + } + else + { + if (write == true) + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_WUF), + true, + &derived->declared_at); + else + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_RUF), + true, + &derived->declared_at); + } + return tb_io_st; +} + + +gfc_symbol * +gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + gfc_symbol *dtio_sub = NULL; + gfc_symbol *extended; + gfc_typebound_proc *tb_io_proc, *specific_proc; + + tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); + + if (tb_io_st != NULL) + { + const char *genname; + gfc_symtree *st; + + tb_io_proc = tb_io_st->n.tb; + gcc_assert (tb_io_proc != NULL); + gcc_assert (tb_io_proc->is_generic); + gcc_assert (tb_io_proc->u.generic->next == NULL); + + specific_proc = tb_io_proc->u.generic->specific; + gcc_assert (!specific_proc->is_generic); + + /* Go back and make sure that we have the right specific procedure. + Here we most likely have a procedure from the parent type, which + can be overridden in extensions. */ + genname = tb_io_proc->u.generic->specific_st->name; + st = gfc_find_typebound_proc (derived, NULL, genname, + true, &tb_io_proc->where); + if (st) + dtio_sub = st->n.tb->u.specific->n.sym; + else + dtio_sub = specific_proc->u.specific->n.sym; + + goto finish; + } + + /* If there is not a typebound binding, look for a generic + DTIO interface. */ + for (extended = derived; extended; + extended = gfc_get_derived_super_type (extended)) + { + if (extended == NULL || extended->ns == NULL + || extended->attr.flavor == FL_UNKNOWN) + return NULL; + + if (formatted == true) + { + if (write == true) + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_WF)); + else + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_RF)); + } + else + { + if (write == true) + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_WUF)); + else + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_RUF)); + } + + if (tb_io_st != NULL + && tb_io_st->n.sym + && tb_io_st->n.sym->generic) + { + for (gfc_interface *intr = tb_io_st->n.sym->generic; + intr && intr->sym; intr = intr->next) + { + if (intr->sym->formal) + { + gfc_symbol *fsym = intr->sym->formal->sym; + if ((fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->ts.u.derived == extended) + || (fsym->ts.type == BT_DERIVED + && fsym->ts.u.derived == extended)) + { + dtio_sub = intr->sym; + break; + } + } + } + } + } + +finish: + if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived) + gfc_find_derived_vtab (derived); + + return dtio_sub; +} |