1 /* Deal with interfaces.
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
24 /* Deal with interfaces. An explicit interface is represented as a
25 singly linked list of formal argument structures attached to the
26 relevant symbols. For an implicit interface, the arguments don't
27 point to symbols. Explicit interfaces point to namespaces that
28 contain the symbols within that interface.
30 Implicit interfaces are linked together in a singly linked list
31 along the next_if member of symbol nodes. Since a particular
32 symbol can only have a single explicit interface, the symbol cannot
33 be part of multiple lists and a single next-member suffices.
35 This is not the case for general classes, though. An operator
36 definition is independent of just about all other uses and has it's
40 Nameless interfaces create symbols with explicit interfaces within
41 the current namespace. They are otherwise unlinked.
44 The generic name points to a linked list of symbols. Each symbol
45 has an explicit interface. Each explicit interface has its own
46 namespace containing the arguments. Module procedures are symbols in
47 which the interface is added later when the module procedure is parsed.
50 User-defined operators are stored in a their own set of symtrees
51 separate from regular symbols. The symtrees point to gfc_user_op
52 structures which in turn head up a list of relevant interfaces.
54 Extended intrinsics and assignment:
55 The head of these interface lists are stored in the containing namespace.
58 An implicit interface is represented as a singly linked list of
59 formal argument list structures that don't point to any symbol
60 nodes -- they just contain types.
63 When a subprogram is defined, the program unit's name points to an
64 interface as usual, but the link to the namespace is NULL and the
65 formal argument list points to symbols within the same namespace as
66 the program unit name. */
74 /* The current_interface structure holds information about the
75 interface currently being parsed. This structure is saved and
76 restored during recursive interfaces. */
78 gfc_interface_info current_interface;
81 /* Free a singly linked list of gfc_interface structures. */
84 gfc_free_interface (gfc_interface *intr)
88 for (; intr; intr = next)
96 /* Change the operators unary plus and minus into binary plus and
97 minus respectively, leaving the rest unchanged. */
99 static gfc_intrinsic_op
100 fold_unary_intrinsic (gfc_intrinsic_op op)
104 case INTRINSIC_UPLUS:
107 case INTRINSIC_UMINUS:
108 op = INTRINSIC_MINUS;
118 /* Match a generic specification. Depending on which type of
119 interface is found, the 'name' or 'op' pointers may be set.
120 This subroutine doesn't return MATCH_NO. */
123 gfc_match_generic_spec (interface_type *type,
125 gfc_intrinsic_op *op)
127 char buffer[GFC_MAX_SYMBOL_LEN + 1];
131 if (gfc_match (" assignment ( = )") == MATCH_YES)
133 *type = INTERFACE_INTRINSIC_OP;
134 *op = INTRINSIC_ASSIGN;
138 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
140 *type = INTERFACE_INTRINSIC_OP;
141 *op = fold_unary_intrinsic (i);
145 *op = INTRINSIC_NONE;
146 if (gfc_match (" operator ( ") == MATCH_YES)
148 m = gfc_match_defined_op_name (buffer, 1);
154 m = gfc_match_char (')');
160 strcpy (name, buffer);
161 *type = INTERFACE_USER_OP;
165 if (gfc_match_name (buffer) == MATCH_YES)
167 strcpy (name, buffer);
168 *type = INTERFACE_GENERIC;
172 *type = INTERFACE_NAMELESS;
176 gfc_error ("Syntax error in generic specification at %C");
181 /* Match one of the five F95 forms of an interface statement. The
182 matcher for the abstract interface follows. */
185 gfc_match_interface (void)
187 char name[GFC_MAX_SYMBOL_LEN + 1];
193 m = gfc_match_space ();
195 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
198 /* If we're not looking at the end of the statement now, or if this
199 is not a nameless interface but we did not see a space, punt. */
200 if (gfc_match_eos () != MATCH_YES
201 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
203 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
208 current_interface.type = type;
212 case INTERFACE_GENERIC:
213 if (gfc_get_symbol (name, NULL, &sym))
216 if (!sym->attr.generic
217 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
222 gfc_error ("Dummy procedure '%s' at %C cannot have a "
223 "generic interface", sym->name);
227 current_interface.sym = gfc_new_block = sym;
230 case INTERFACE_USER_OP:
231 current_interface.uop = gfc_get_uop (name);
234 case INTERFACE_INTRINSIC_OP:
235 current_interface.op = op;
238 case INTERFACE_NAMELESS:
239 case INTERFACE_ABSTRACT:
248 /* Match a F2003 abstract interface. */
251 gfc_match_abstract_interface (void)
255 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
259 m = gfc_match_eos ();
263 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
267 current_interface.type = INTERFACE_ABSTRACT;
273 /* Match the different sort of generic-specs that can be present after
274 the END INTERFACE itself. */
277 gfc_match_end_interface (void)
279 char name[GFC_MAX_SYMBOL_LEN + 1];
284 m = gfc_match_space ();
286 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
289 /* If we're not looking at the end of the statement now, or if this
290 is not a nameless interface but we did not see a space, punt. */
291 if (gfc_match_eos () != MATCH_YES
292 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
294 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
301 switch (current_interface.type)
303 case INTERFACE_NAMELESS:
304 case INTERFACE_ABSTRACT:
305 if (type != INTERFACE_NAMELESS)
307 gfc_error ("Expected a nameless interface at %C");
313 case INTERFACE_INTRINSIC_OP:
314 if (type != current_interface.type || op != current_interface.op)
317 if (current_interface.op == INTRINSIC_ASSIGN)
320 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
325 s1 = gfc_op2string (current_interface.op);
326 s2 = gfc_op2string (op);
328 /* The following if-statements are used to enforce C1202
330 if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
331 || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
333 if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
334 || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
336 if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
337 || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
339 if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
340 || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
342 if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
343 || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
345 if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
346 || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
350 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
351 "but got %s", s1, s2);
358 case INTERFACE_USER_OP:
359 /* Comparing the symbol node names is OK because only use-associated
360 symbols can be renamed. */
361 if (type != current_interface.type
362 || strcmp (current_interface.uop->name, name) != 0)
364 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
365 current_interface.uop->name);
371 case INTERFACE_GENERIC:
372 if (type != current_interface.type
373 || strcmp (current_interface.sym->name, name) != 0)
375 gfc_error ("Expecting 'END INTERFACE %s' at %C",
376 current_interface.sym->name);
387 /* Compare two derived types using the criteria in 4.4.2 of the standard,
388 recursing through gfc_compare_types for the components. */
391 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
393 gfc_component *dt1, *dt2;
395 if (derived1 == derived2)
398 /* Special case for comparing derived types across namespaces. If the
399 true names and module names are the same and the module name is
400 nonnull, then they are equal. */
401 if (derived1 != NULL && derived2 != NULL
402 && strcmp (derived1->name, derived2->name) == 0
403 && derived1->module != NULL && derived2->module != NULL
404 && strcmp (derived1->module, derived2->module) == 0)
407 /* Compare type via the rules of the standard. Both types must have
408 the SEQUENCE or BIND(C) attribute to be equal. */
410 if (strcmp (derived1->name, derived2->name))
413 if (derived1->component_access == ACCESS_PRIVATE
414 || derived2->component_access == ACCESS_PRIVATE)
417 if (!(derived1->attr.sequence && derived2->attr.sequence)
418 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
421 dt1 = derived1->components;
422 dt2 = derived2->components;
424 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
425 simple test can speed things up. Otherwise, lots of things have to
429 if (strcmp (dt1->name, dt2->name) != 0)
432 if (dt1->attr.access != dt2->attr.access)
435 if (dt1->attr.pointer != dt2->attr.pointer)
438 if (dt1->attr.dimension != dt2->attr.dimension)
441 if (dt1->attr.allocatable != dt2->attr.allocatable)
444 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
447 /* Make sure that link lists do not put this function into an
448 endless recursive loop! */
449 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
450 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
451 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
454 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
455 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
458 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
459 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
465 if (dt1 == NULL && dt2 == NULL)
467 if (dt1 == NULL || dt2 == NULL)
475 /* Compare two typespecs, recursively if necessary. */
478 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
480 /* See if one of the typespecs is a BT_VOID, which is what is being used
481 to allow the funcs like c_f_pointer to accept any pointer type.
482 TODO: Possibly should narrow this to just the one typespec coming in
483 that is for the formal arg, but oh well. */
484 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
487 if (ts1->type != ts2->type
488 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
489 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
491 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
492 return (ts1->kind == ts2->kind);
494 /* Compare derived types. */
495 if (gfc_type_compatible (ts1, ts2))
498 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
502 /* Given two symbols that are formal arguments, compare their ranks
503 and types. Returns nonzero if they have the same rank and type,
507 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
511 r1 = (s1->as != NULL) ? s1->as->rank : 0;
512 r2 = (s2->as != NULL) ? s2->as->rank : 0;
515 return 0; /* Ranks differ. */
517 return gfc_compare_types (&s1->ts, &s2->ts);
521 /* Given two symbols that are formal arguments, compare their types
522 and rank and their formal interfaces if they are both dummy
523 procedures. Returns nonzero if the same, zero if different. */
526 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
528 if (s1 == NULL || s2 == NULL)
529 return s1 == s2 ? 1 : 0;
534 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
535 return compare_type_rank (s1, s2);
537 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
540 /* At this point, both symbols are procedures. It can happen that
541 external procedures are compared, where one is identified by usage
542 to be a function or subroutine but the other is not. Check TKR
543 nonetheless for these cases. */
544 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
545 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
547 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
548 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
550 /* Now the type of procedure has been identified. */
551 if (s1->attr.function != s2->attr.function
552 || s1->attr.subroutine != s2->attr.subroutine)
555 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
558 /* Originally, gfortran recursed here to check the interfaces of passed
559 procedures. This is explicitly not required by the standard. */
564 /* Given a formal argument list and a keyword name, search the list
565 for that keyword. Returns the correct symbol node if found, NULL
569 find_keyword_arg (const char *name, gfc_formal_arglist *f)
571 for (; f; f = f->next)
572 if (strcmp (f->sym->name, name) == 0)
579 /******** Interface checking subroutines **********/
582 /* Given an operator interface and the operator, make sure that all
583 interfaces for that operator are legal. */
586 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
589 gfc_formal_arglist *formal;
592 int args, r1, r2, k1, k2;
597 t1 = t2 = BT_UNKNOWN;
598 i1 = i2 = INTENT_UNKNOWN;
602 for (formal = sym->formal; formal; formal = formal->next)
604 gfc_symbol *fsym = formal->sym;
607 gfc_error ("Alternate return cannot appear in operator "
608 "interface at %L", &sym->declared_at);
614 i1 = fsym->attr.intent;
615 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
621 i2 = fsym->attr.intent;
622 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
628 /* Only +, - and .not. can be unary operators.
629 .not. cannot be a binary operator. */
630 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
631 && op != INTRINSIC_MINUS
632 && op != INTRINSIC_NOT)
633 || (args == 2 && op == INTRINSIC_NOT))
635 gfc_error ("Operator interface at %L has the wrong number of arguments",
640 /* Check that intrinsics are mapped to functions, except
641 INTRINSIC_ASSIGN which should map to a subroutine. */
642 if (op == INTRINSIC_ASSIGN)
644 if (!sym->attr.subroutine)
646 gfc_error ("Assignment operator interface at %L must be "
647 "a SUBROUTINE", &sym->declared_at);
652 gfc_error ("Assignment operator interface at %L must have "
653 "two arguments", &sym->declared_at);
657 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
658 - First argument an array with different rank than second,
659 - First argument is a scalar and second an array,
660 - Types and kinds do not conform, or
661 - First argument is of derived type. */
662 if (sym->formal->sym->ts.type != BT_DERIVED
663 && sym->formal->sym->ts.type != BT_CLASS
664 && (r2 == 0 || r1 == r2)
665 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
666 || (gfc_numeric_ts (&sym->formal->sym->ts)
667 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
669 gfc_error ("Assignment operator interface at %L must not redefine "
670 "an INTRINSIC type assignment", &sym->declared_at);
676 if (!sym->attr.function)
678 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
684 /* Check intents on operator interfaces. */
685 if (op == INTRINSIC_ASSIGN)
687 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
689 gfc_error ("First argument of defined assignment at %L must be "
690 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
696 gfc_error ("Second argument of defined assignment at %L must be "
697 "INTENT(IN)", &sym->declared_at);
705 gfc_error ("First argument of operator interface at %L must be "
706 "INTENT(IN)", &sym->declared_at);
710 if (args == 2 && i2 != INTENT_IN)
712 gfc_error ("Second argument of operator interface at %L must be "
713 "INTENT(IN)", &sym->declared_at);
718 /* From now on, all we have to do is check that the operator definition
719 doesn't conflict with an intrinsic operator. The rules for this
720 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
721 as well as 12.3.2.1.1 of Fortran 2003:
723 "If the operator is an intrinsic-operator (R310), the number of
724 function arguments shall be consistent with the intrinsic uses of
725 that operator, and the types, kind type parameters, or ranks of the
726 dummy arguments shall differ from those required for the intrinsic
727 operation (7.1.2)." */
729 #define IS_NUMERIC_TYPE(t) \
730 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
732 /* Unary ops are easy, do them first. */
733 if (op == INTRINSIC_NOT)
735 if (t1 == BT_LOGICAL)
741 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
743 if (IS_NUMERIC_TYPE (t1))
749 /* Character intrinsic operators have same character kind, thus
750 operator definitions with operands of different character kinds
752 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
755 /* Intrinsic operators always perform on arguments of same rank,
756 so different ranks is also always safe. (rank == 0) is an exception
757 to that, because all intrinsic operators are elemental. */
758 if (r1 != r2 && r1 != 0 && r2 != 0)
764 case INTRINSIC_EQ_OS:
766 case INTRINSIC_NE_OS:
767 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
772 case INTRINSIC_MINUS:
773 case INTRINSIC_TIMES:
774 case INTRINSIC_DIVIDE:
775 case INTRINSIC_POWER:
776 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
781 case INTRINSIC_GT_OS:
783 case INTRINSIC_GE_OS:
785 case INTRINSIC_LT_OS:
787 case INTRINSIC_LE_OS:
788 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
790 if ((t1 == BT_INTEGER || t1 == BT_REAL)
791 && (t2 == BT_INTEGER || t2 == BT_REAL))
795 case INTRINSIC_CONCAT:
796 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
804 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
814 #undef IS_NUMERIC_TYPE
817 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
823 /* Given a pair of formal argument lists, we see if the two lists can
824 be distinguished by counting the number of nonoptional arguments of
825 a given type/rank in f1 and seeing if there are less then that
826 number of those arguments in f2 (including optional arguments).
827 Since this test is asymmetric, it has to be called twice to make it
828 symmetric. Returns nonzero if the argument lists are incompatible
829 by this test. This subroutine implements rule 1 of section
830 14.1.2.3 in the Fortran 95 standard. */
833 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
835 int rc, ac1, ac2, i, j, k, n1;
836 gfc_formal_arglist *f;
849 for (f = f1; f; f = f->next)
852 /* Build an array of integers that gives the same integer to
853 arguments of the same type/rank. */
854 arg = XCNEWVEC (arginfo, n1);
857 for (i = 0; i < n1; i++, f = f->next)
865 for (i = 0; i < n1; i++)
867 if (arg[i].flag != -1)
870 if (arg[i].sym && arg[i].sym->attr.optional)
871 continue; /* Skip optional arguments. */
875 /* Find other nonoptional arguments of the same type/rank. */
876 for (j = i + 1; j < n1; j++)
877 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
878 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
879 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
885 /* Now loop over each distinct type found in f1. */
889 for (i = 0; i < n1; i++)
891 if (arg[i].flag != k)
895 for (j = i + 1; j < n1; j++)
896 if (arg[j].flag == k)
899 /* Count the number of arguments in f2 with that type, including
900 those that are optional. */
903 for (f = f2; f; f = f->next)
904 if (compare_type_rank_if (arg[i].sym, f->sym)
905 || compare_type_rank_if (f->sym, arg[i].sym))
923 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
924 Returns zero if no argument is found that satisfies rule 2, nonzero
927 This test is also not symmetric in f1 and f2 and must be called
928 twice. This test finds problems caused by sorting the actual
929 argument list with keywords. For example:
933 INTEGER :: A ; REAL :: B
937 INTEGER :: A ; REAL :: B
941 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
944 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
946 gfc_formal_arglist *f2_save, *g;
953 if (f1->sym->attr.optional)
956 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
957 || compare_type_rank (f2->sym, f1->sym)))
960 /* Now search for a disambiguating keyword argument starting at
961 the current non-match. */
962 for (g = f1; g; g = g->next)
964 if (g->sym->attr.optional)
967 sym = find_keyword_arg (g->sym->name, f2_save);
968 if (sym == NULL || !compare_type_rank (g->sym, sym))
982 /* Check if the characteristics of two dummy arguments match,
986 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
987 bool type_must_agree, char *errmsg, int err_len)
989 /* Check type and rank. */
990 if (type_must_agree && !compare_type_rank (s2, s1))
993 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
999 if (s1->attr.intent != s2->attr.intent)
1001 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1006 /* Check OPTIONAL attribute. */
1007 if (s1->attr.optional != s2->attr.optional)
1009 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1014 /* Check ALLOCATABLE attribute. */
1015 if (s1->attr.allocatable != s2->attr.allocatable)
1017 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1022 /* Check POINTER attribute. */
1023 if (s1->attr.pointer != s2->attr.pointer)
1025 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1030 /* Check TARGET attribute. */
1031 if (s1->attr.target != s2->attr.target)
1033 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1038 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1039 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1041 /* Check string length. */
1042 if (s1->ts.type == BT_CHARACTER
1043 && s1->ts.u.cl && s1->ts.u.cl->length
1044 && s2->ts.u.cl && s2->ts.u.cl->length)
1046 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1047 s2->ts.u.cl->length);
1053 snprintf (errmsg, err_len, "Character length mismatch "
1054 "in argument '%s'", s1->name);
1058 /* FIXME: Implement a warning for this case.
1059 gfc_warning ("Possible character length mismatch in argument '%s'",
1067 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1068 "%i of gfc_dep_compare_expr", compval);
1073 /* Check array shape. */
1074 if (s1->as && s2->as)
1077 gfc_expr *shape1, *shape2;
1079 if (s1->as->type != s2->as->type)
1081 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1086 if (s1->as->type == AS_EXPLICIT)
1087 for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1089 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1090 gfc_copy_expr (s1->as->lower[i]));
1091 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1092 gfc_copy_expr (s2->as->lower[i]));
1093 compval = gfc_dep_compare_expr (shape1, shape2);
1094 gfc_free_expr (shape1);
1095 gfc_free_expr (shape2);
1101 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1102 "argument '%s'", i + 1, s1->name);
1106 /* FIXME: Implement a warning for this case.
1107 gfc_warning ("Possible shape mismatch in argument '%s'",
1115 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1116 "result %i of gfc_dep_compare_expr",
1127 /* 'Compare' two formal interfaces associated with a pair of symbols.
1128 We return nonzero if there exists an actual argument list that
1129 would be ambiguous between the two interfaces, zero otherwise.
1130 'strict_flag' specifies whether all the characteristics are
1131 required to match, which is not the case for ambiguity checks.*/
1134 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1135 int generic_flag, int strict_flag,
1136 char *errmsg, int err_len)
1138 gfc_formal_arglist *f1, *f2;
1140 gcc_assert (name2 != NULL);
1142 if (s1->attr.function && (s2->attr.subroutine
1143 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1144 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1147 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1151 if (s1->attr.subroutine && s2->attr.function)
1154 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1158 /* Do strict checks on all characteristics
1159 (for dummy procedures and procedure pointer assignments). */
1160 if (!generic_flag && strict_flag)
1162 if (s1->attr.function && s2->attr.function)
1164 /* If both are functions, check result type. */
1165 if (s1->ts.type == BT_UNKNOWN)
1167 if (!compare_type_rank (s1,s2))
1170 snprintf (errmsg, err_len, "Type/rank mismatch in return value "
1175 /* FIXME: Check array bounds and string length of result. */
1178 if (s1->attr.pure && !s2->attr.pure)
1180 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1183 if (s1->attr.elemental && !s2->attr.elemental)
1185 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1190 if (s1->attr.if_source == IFSRC_UNKNOWN
1191 || s2->attr.if_source == IFSRC_UNKNOWN)
1197 if (f1 == NULL && f2 == NULL)
1198 return 1; /* Special case: No arguments. */
1202 if (count_types_test (f1, f2) || count_types_test (f2, f1))
1204 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1208 /* Perform the abbreviated correspondence test for operators (the
1209 arguments cannot be optional and are always ordered correctly).
1210 This is also done when comparing interfaces for dummy procedures and in
1211 procedure pointer assignments. */
1215 /* Check existence. */
1216 if (f1 == NULL && f2 == NULL)
1218 if (f1 == NULL || f2 == NULL)
1221 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1222 "arguments", name2);
1228 /* Check all characteristics. */
1229 if (check_dummy_characteristics (f1->sym, f2->sym,
1230 true, errmsg, err_len) == FAILURE)
1233 else if (!compare_type_rank (f2->sym, f1->sym))
1235 /* Only check type and rank. */
1237 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1250 /* Given a pointer to an interface pointer, remove duplicate
1251 interfaces and make sure that all symbols are either functions
1252 or subroutines, and all of the same kind. Returns nonzero if
1253 something goes wrong. */
1256 check_interface0 (gfc_interface *p, const char *interface_name)
1258 gfc_interface *psave, *q, *qlast;
1261 for (; p; p = p->next)
1263 /* Make sure all symbols in the interface have been defined as
1264 functions or subroutines. */
1265 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1266 || !p->sym->attr.if_source)
1268 if (p->sym->attr.external)
1269 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1270 p->sym->name, interface_name, &p->sym->declared_at);
1272 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1273 "subroutine", p->sym->name, interface_name,
1274 &p->sym->declared_at);
1278 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1279 if ((psave->sym->attr.function && !p->sym->attr.function)
1280 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1282 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1283 " or all FUNCTIONs", interface_name, &p->sym->declared_at);
1287 if (p->sym->attr.proc == PROC_INTERNAL
1288 && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' "
1289 "in %s at %L", p->sym->name, interface_name,
1290 &p->sym->declared_at) == FAILURE)
1295 /* Remove duplicate interfaces in this interface list. */
1296 for (; p; p = p->next)
1300 for (q = p->next; q;)
1302 if (p->sym != q->sym)
1309 /* Duplicate interface. */
1310 qlast->next = q->next;
1321 /* Check lists of interfaces to make sure that no two interfaces are
1322 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1325 check_interface1 (gfc_interface *p, gfc_interface *q0,
1326 int generic_flag, const char *interface_name,
1330 for (; p; p = p->next)
1331 for (q = q0; q; q = q->next)
1333 if (p->sym == q->sym)
1334 continue; /* Duplicates OK here. */
1336 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1339 if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
1343 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1344 p->sym->name, q->sym->name, interface_name,
1346 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1347 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1348 p->sym->name, q->sym->name, interface_name,
1351 gfc_warning ("Although not referenced, '%s' has ambiguous "
1352 "interfaces at %L", interface_name, &p->where);
1360 /* Check the generic and operator interfaces of symbols to make sure
1361 that none of the interfaces conflict. The check has to be done
1362 after all of the symbols are actually loaded. */
1365 check_sym_interfaces (gfc_symbol *sym)
1367 char interface_name[100];
1370 if (sym->ns != gfc_current_ns)
1373 if (sym->generic != NULL)
1375 sprintf (interface_name, "generic interface '%s'", sym->name);
1376 if (check_interface0 (sym->generic, interface_name))
1379 for (p = sym->generic; p; p = p->next)
1381 if (p->sym->attr.mod_proc
1382 && (p->sym->attr.if_source != IFSRC_DECL
1383 || p->sym->attr.procedure))
1385 gfc_error ("'%s' at %L is not a module procedure",
1386 p->sym->name, &p->where);
1391 /* Originally, this test was applied to host interfaces too;
1392 this is incorrect since host associated symbols, from any
1393 source, cannot be ambiguous with local symbols. */
1394 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1395 sym->attr.referenced || !sym->attr.use_assoc);
1401 check_uop_interfaces (gfc_user_op *uop)
1403 char interface_name[100];
1407 sprintf (interface_name, "operator interface '%s'", uop->name);
1408 if (check_interface0 (uop->op, interface_name))
1411 for (ns = gfc_current_ns; ns; ns = ns->parent)
1413 uop2 = gfc_find_uop (uop->name, ns);
1417 check_interface1 (uop->op, uop2->op, 0,
1418 interface_name, true);
1422 /* Given an intrinsic op, return an equivalent op if one exists,
1423 or INTRINSIC_NONE otherwise. */
1426 gfc_equivalent_op (gfc_intrinsic_op op)
1431 return INTRINSIC_EQ_OS;
1433 case INTRINSIC_EQ_OS:
1434 return INTRINSIC_EQ;
1437 return INTRINSIC_NE_OS;
1439 case INTRINSIC_NE_OS:
1440 return INTRINSIC_NE;
1443 return INTRINSIC_GT_OS;
1445 case INTRINSIC_GT_OS:
1446 return INTRINSIC_GT;
1449 return INTRINSIC_GE_OS;
1451 case INTRINSIC_GE_OS:
1452 return INTRINSIC_GE;
1455 return INTRINSIC_LT_OS;
1457 case INTRINSIC_LT_OS:
1458 return INTRINSIC_LT;
1461 return INTRINSIC_LE_OS;
1463 case INTRINSIC_LE_OS:
1464 return INTRINSIC_LE;
1467 return INTRINSIC_NONE;
1471 /* For the namespace, check generic, user operator and intrinsic
1472 operator interfaces for consistency and to remove duplicate
1473 interfaces. We traverse the whole namespace, counting on the fact
1474 that most symbols will not have generic or operator interfaces. */
1477 gfc_check_interfaces (gfc_namespace *ns)
1479 gfc_namespace *old_ns, *ns2;
1480 char interface_name[100];
1483 old_ns = gfc_current_ns;
1484 gfc_current_ns = ns;
1486 gfc_traverse_ns (ns, check_sym_interfaces);
1488 gfc_traverse_user_op (ns, check_uop_interfaces);
1490 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1492 if (i == INTRINSIC_USER)
1495 if (i == INTRINSIC_ASSIGN)
1496 strcpy (interface_name, "intrinsic assignment operator");
1498 sprintf (interface_name, "intrinsic '%s' operator",
1499 gfc_op2string ((gfc_intrinsic_op) i));
1501 if (check_interface0 (ns->op[i], interface_name))
1505 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1508 for (ns2 = ns; ns2; ns2 = ns2->parent)
1510 gfc_intrinsic_op other_op;
1512 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1513 interface_name, true))
1516 /* i should be gfc_intrinsic_op, but has to be int with this cast
1517 here for stupid C++ compatibility rules. */
1518 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1519 if (other_op != INTRINSIC_NONE
1520 && check_interface1 (ns->op[i], ns2->op[other_op],
1521 0, interface_name, true))
1527 gfc_current_ns = old_ns;
1532 symbol_rank (gfc_symbol *sym)
1534 return (sym->as == NULL) ? 0 : sym->as->rank;
1538 /* Given a symbol of a formal argument list and an expression, if the
1539 formal argument is allocatable, check that the actual argument is
1540 allocatable. Returns nonzero if compatible, zero if not compatible. */
1543 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1545 symbol_attribute attr;
1547 if (formal->attr.allocatable
1548 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1550 attr = gfc_expr_attr (actual);
1551 if (!attr.allocatable)
1559 /* Given a symbol of a formal argument list and an expression, if the
1560 formal argument is a pointer, see if the actual argument is a
1561 pointer. Returns nonzero if compatible, zero if not compatible. */
1564 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1566 symbol_attribute attr;
1568 if (formal->attr.pointer)
1570 attr = gfc_expr_attr (actual);
1572 /* Fortran 2008 allows non-pointer actual arguments. */
1573 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1584 /* Emit clear error messages for rank mismatch. */
1587 argument_rank_mismatch (const char *name, locus *where,
1588 int rank1, int rank2)
1592 gfc_error ("Rank mismatch in argument '%s' at %L "
1593 "(scalar and rank-%d)", name, where, rank2);
1595 else if (rank2 == 0)
1597 gfc_error ("Rank mismatch in argument '%s' at %L "
1598 "(rank-%d and scalar)", name, where, rank1);
1602 gfc_error ("Rank mismatch in argument '%s' at %L "
1603 "(rank-%d and rank-%d)", name, where, rank1, rank2);
1608 /* Given a symbol of a formal argument list and an expression, see if
1609 the two are compatible as arguments. Returns nonzero if
1610 compatible, zero if not compatible. */
1613 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1614 int ranks_must_agree, int is_elemental, locus *where)
1617 bool rank_check, is_pointer;
1619 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1620 procs c_f_pointer or c_f_procpointer, and we need to accept most
1621 pointers the user could give us. This should allow that. */
1622 if (formal->ts.type == BT_VOID)
1625 if (formal->ts.type == BT_DERIVED
1626 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1627 && actual->ts.type == BT_DERIVED
1628 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1631 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1632 /* Make sure the vtab symbol is present when
1633 the module variables are generated. */
1634 gfc_find_derived_vtab (actual->ts.u.derived);
1636 if (actual->ts.type == BT_PROCEDURE)
1639 gfc_symbol *act_sym = actual->symtree->n.sym;
1641 if (formal->attr.flavor != FL_PROCEDURE)
1644 gfc_error ("Invalid procedure argument at %L", &actual->where);
1648 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1652 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1653 formal->name, &actual->where, err);
1657 if (formal->attr.function && !act_sym->attr.function)
1659 gfc_add_function (&act_sym->attr, act_sym->name,
1660 &act_sym->declared_at);
1661 if (act_sym->ts.type == BT_UNKNOWN
1662 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1665 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1666 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1667 &act_sym->declared_at);
1673 if (formal->attr.pointer && formal->attr.contiguous
1674 && !gfc_is_simply_contiguous (actual, true))
1677 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1678 "must be simply contigous", formal->name, &actual->where);
1682 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1683 && actual->ts.type != BT_HOLLERITH
1684 && !gfc_compare_types (&formal->ts, &actual->ts))
1687 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1688 formal->name, &actual->where, gfc_typename (&actual->ts),
1689 gfc_typename (&formal->ts));
1693 /* F2003, 12.5.2.5. */
1694 if (formal->ts.type == BT_CLASS
1695 && (CLASS_DATA (formal)->attr.class_pointer
1696 || CLASS_DATA (formal)->attr.allocatable))
1698 if (actual->ts.type != BT_CLASS)
1701 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1702 formal->name, &actual->where);
1705 if (CLASS_DATA (actual)->ts.u.derived
1706 != CLASS_DATA (formal)->ts.u.derived)
1709 gfc_error ("Actual argument to '%s' at %L must have the same "
1710 "declared type", formal->name, &actual->where);
1715 if (formal->attr.codimension && !gfc_is_coarray (actual))
1718 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1719 formal->name, &actual->where);
1723 if (formal->attr.codimension && formal->attr.allocatable)
1725 gfc_ref *last = NULL;
1727 for (ref = actual->ref; ref; ref = ref->next)
1728 if (ref->type == REF_COMPONENT)
1731 /* F2008, 12.5.2.6. */
1732 if ((last && last->u.c.component->as->corank != formal->as->corank)
1734 && actual->symtree->n.sym->as->corank != formal->as->corank))
1737 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1738 formal->name, &actual->where, formal->as->corank,
1739 last ? last->u.c.component->as->corank
1740 : actual->symtree->n.sym->as->corank);
1745 if (formal->attr.codimension)
1747 /* F2008, 12.5.2.8. */
1748 if (formal->attr.dimension
1749 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1750 && gfc_expr_attr (actual).dimension
1751 && !gfc_is_simply_contiguous (actual, true))
1754 gfc_error ("Actual argument to '%s' at %L must be simply "
1755 "contiguous", formal->name, &actual->where);
1759 /* F2008, C1303 and C1304. */
1760 if (formal->attr.intent != INTENT_INOUT
1761 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1762 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1763 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1764 || formal->attr.lock_comp))
1768 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1769 "which is LOCK_TYPE or has a LOCK_TYPE component",
1770 formal->name, &actual->where);
1775 /* F2008, C1239/C1240. */
1776 if (actual->expr_type == EXPR_VARIABLE
1777 && (actual->symtree->n.sym->attr.asynchronous
1778 || actual->symtree->n.sym->attr.volatile_)
1779 && (formal->attr.asynchronous || formal->attr.volatile_)
1780 && actual->rank && !gfc_is_simply_contiguous (actual, true)
1781 && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1782 || formal->attr.contiguous))
1785 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1786 "array without CONTIGUOUS attribute - as actual argument at"
1787 " %L is not simply contiguous and both are ASYNCHRONOUS "
1788 "or VOLATILE", formal->name, &actual->where);
1792 if (formal->attr.allocatable && !formal->attr.codimension
1793 && gfc_expr_attr (actual).codimension)
1795 if (formal->attr.intent == INTENT_OUT)
1798 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1799 "INTENT(OUT) dummy argument '%s'", &actual->where,
1803 else if (gfc_option.warn_surprising && where
1804 && formal->attr.intent != INTENT_IN)
1805 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1806 "argument '%s', which is invalid if the allocation status"
1807 " is modified", &actual->where, formal->name);
1810 if (symbol_rank (formal) == actual->rank)
1813 rank_check = where != NULL && !is_elemental && formal->as
1814 && (formal->as->type == AS_ASSUMED_SHAPE
1815 || formal->as->type == AS_DEFERRED)
1816 && actual->expr_type != EXPR_NULL;
1818 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1819 if (rank_check || ranks_must_agree
1820 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1821 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1822 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
1823 && actual->expr_type != EXPR_NULL)
1824 || (actual->rank == 0 && formal->attr.dimension
1825 && gfc_is_coindexed (actual)))
1828 argument_rank_mismatch (formal->name, &actual->where,
1829 symbol_rank (formal), actual->rank);
1832 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1835 /* At this point, we are considering a scalar passed to an array. This
1836 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1837 - if the actual argument is (a substring of) an element of a
1838 non-assumed-shape/non-pointer/non-polymorphic array; or
1839 - (F2003) if the actual argument is of type character of default/c_char
1842 is_pointer = actual->expr_type == EXPR_VARIABLE
1843 ? actual->symtree->n.sym->attr.pointer : false;
1845 for (ref = actual->ref; ref; ref = ref->next)
1847 if (ref->type == REF_COMPONENT)
1848 is_pointer = ref->u.c.component->attr.pointer;
1849 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1850 && ref->u.ar.dimen > 0
1852 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
1856 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
1859 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1860 "at %L", formal->name, &actual->where);
1864 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
1865 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1868 gfc_error ("Element of assumed-shaped or pointer "
1869 "array passed to array dummy argument '%s' at %L",
1870 formal->name, &actual->where);
1874 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
1875 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1877 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
1880 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1881 "CHARACTER actual argument with array dummy argument "
1882 "'%s' at %L", formal->name, &actual->where);
1886 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1888 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1889 "array dummy argument '%s' at %L",
1890 formal->name, &actual->where);
1893 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1899 if (ref == NULL && actual->expr_type != EXPR_NULL)
1902 argument_rank_mismatch (formal->name, &actual->where,
1903 symbol_rank (formal), actual->rank);
1911 /* Returns the storage size of a symbol (formal argument) or
1912 zero if it cannot be determined. */
1914 static unsigned long
1915 get_sym_storage_size (gfc_symbol *sym)
1918 unsigned long strlen, elements;
1920 if (sym->ts.type == BT_CHARACTER)
1922 if (sym->ts.u.cl && sym->ts.u.cl->length
1923 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1924 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1931 if (symbol_rank (sym) == 0)
1935 if (sym->as->type != AS_EXPLICIT)
1937 for (i = 0; i < sym->as->rank; i++)
1939 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1940 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1943 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
1944 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
1947 return strlen*elements;
1951 /* Returns the storage size of an expression (actual argument) or
1952 zero if it cannot be determined. For an array element, it returns
1953 the remaining size as the element sequence consists of all storage
1954 units of the actual argument up to the end of the array. */
1956 static unsigned long
1957 get_expr_storage_size (gfc_expr *e)
1960 long int strlen, elements;
1961 long int substrlen = 0;
1962 bool is_str_storage = false;
1968 if (e->ts.type == BT_CHARACTER)
1970 if (e->ts.u.cl && e->ts.u.cl->length
1971 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1972 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1973 else if (e->expr_type == EXPR_CONSTANT
1974 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1975 strlen = e->value.character.length;
1980 strlen = 1; /* Length per element. */
1982 if (e->rank == 0 && !e->ref)
1990 for (i = 0; i < e->rank; i++)
1991 elements *= mpz_get_si (e->shape[i]);
1992 return elements*strlen;
1995 for (ref = e->ref; ref; ref = ref->next)
1997 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1998 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2002 /* The string length is the substring length.
2003 Set now to full string length. */
2004 if (!ref->u.ss.length || !ref->u.ss.length->length
2005 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2008 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2010 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2014 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
2015 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
2016 && ref->u.ar.as->upper)
2017 for (i = 0; i < ref->u.ar.dimen; i++)
2019 long int start, end, stride;
2022 if (ref->u.ar.stride[i])
2024 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2025 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2030 if (ref->u.ar.start[i])
2032 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2033 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2037 else if (ref->u.ar.as->lower[i]
2038 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2039 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2043 if (ref->u.ar.end[i])
2045 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2046 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2050 else if (ref->u.ar.as->upper[i]
2051 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2052 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2056 elements *= (end - start)/stride + 1L;
2058 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
2059 && ref->u.ar.as->lower && ref->u.ar.as->upper)
2060 for (i = 0; i < ref->u.ar.as->rank; i++)
2062 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2063 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2064 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2065 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2066 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2071 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2072 && e->expr_type == EXPR_VARIABLE)
2074 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2075 || e->symtree->n.sym->attr.pointer)
2081 /* Determine the number of remaining elements in the element
2082 sequence for array element designators. */
2083 is_str_storage = true;
2084 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2086 if (ref->u.ar.start[i] == NULL
2087 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2088 || ref->u.ar.as->upper[i] == NULL
2089 || ref->u.ar.as->lower[i] == NULL
2090 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2091 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2096 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2097 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2099 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2100 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2106 return (is_str_storage) ? substrlen + (elements-1)*strlen
2109 return elements*strlen;
2113 /* Given an expression, check whether it is an array section
2114 which has a vector subscript. If it has, one is returned,
2118 gfc_has_vector_subscript (gfc_expr *e)
2123 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2126 for (ref = e->ref; ref; ref = ref->next)
2127 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2128 for (i = 0; i < ref->u.ar.dimen; i++)
2129 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2136 /* Given formal and actual argument lists, see if they are compatible.
2137 If they are compatible, the actual argument list is sorted to
2138 correspond with the formal list, and elements for missing optional
2139 arguments are inserted. If WHERE pointer is nonnull, then we issue
2140 errors when things don't match instead of just returning the status
2144 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2145 int ranks_must_agree, int is_elemental, locus *where)
2147 gfc_actual_arglist **new_arg, *a, *actual, temp;
2148 gfc_formal_arglist *f;
2150 unsigned long actual_size, formal_size;
2154 if (actual == NULL && formal == NULL)
2158 for (f = formal; f; f = f->next)
2161 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2163 for (i = 0; i < n; i++)
2170 for (a = actual; a; a = a->next, f = f->next)
2172 /* Look for keywords but ignore g77 extensions like %VAL. */
2173 if (a->name != NULL && a->name[0] != '%')
2176 for (f = formal; f; f = f->next, i++)
2180 if (strcmp (f->sym->name, a->name) == 0)
2187 gfc_error ("Keyword argument '%s' at %L is not in "
2188 "the procedure", a->name, &a->expr->where);
2192 if (new_arg[i] != NULL)
2195 gfc_error ("Keyword argument '%s' at %L is already associated "
2196 "with another actual argument", a->name,
2205 gfc_error ("More actual than formal arguments in procedure "
2206 "call at %L", where);
2211 if (f->sym == NULL && a->expr == NULL)
2217 gfc_error ("Missing alternate return spec in subroutine call "
2222 if (a->expr == NULL)
2225 gfc_error ("Unexpected alternate return spec in subroutine "
2226 "call at %L", where);
2230 if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
2231 && (f->sym->attr.allocatable || !f->sym->attr.optional
2232 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2234 if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
2235 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2236 where, f->sym->name);
2238 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2239 "dummy '%s'", where, f->sym->name);
2244 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2245 is_elemental, where))
2248 /* Special case for character arguments. For allocatable, pointer
2249 and assumed-shape dummies, the string length needs to match
2251 if (a->expr->ts.type == BT_CHARACTER
2252 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2253 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2254 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2255 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2256 && (f->sym->attr.pointer || f->sym->attr.allocatable
2257 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2258 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2259 f->sym->ts.u.cl->length->value.integer) != 0))
2261 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2262 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2263 "argument and pointer or allocatable dummy argument "
2265 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2266 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2267 f->sym->name, &a->expr->where);
2269 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2270 "argument and assumed-shape dummy argument '%s' "
2272 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2273 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2274 f->sym->name, &a->expr->where);
2278 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2279 && f->sym->ts.deferred != a->expr->ts.deferred
2280 && a->expr->ts.type == BT_CHARACTER)
2283 gfc_error ("Actual argument argument at %L to allocatable or "
2284 "pointer dummy argument '%s' must have a deferred "
2285 "length type parameter if and only if the dummy has one",
2286 &a->expr->where, f->sym->name);
2290 actual_size = get_expr_storage_size (a->expr);
2291 formal_size = get_sym_storage_size (f->sym);
2292 if (actual_size != 0 && actual_size < formal_size
2293 && a->expr->ts.type != BT_PROCEDURE
2294 && f->sym->attr.flavor != FL_PROCEDURE)
2296 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2297 gfc_warning ("Character length of actual argument shorter "
2298 "than of dummy argument '%s' (%lu/%lu) at %L",
2299 f->sym->name, actual_size, formal_size,
2302 gfc_warning ("Actual argument contains too few "
2303 "elements for dummy argument '%s' (%lu/%lu) at %L",
2304 f->sym->name, actual_size, formal_size,
2309 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2310 is provided for a procedure pointer formal argument. */
2311 if (f->sym->attr.proc_pointer
2312 && !((a->expr->expr_type == EXPR_VARIABLE
2313 && a->expr->symtree->n.sym->attr.proc_pointer)
2314 || (a->expr->expr_type == EXPR_FUNCTION
2315 && a->expr->symtree->n.sym->result->attr.proc_pointer)
2316 || gfc_is_proc_ptr_comp (a->expr, NULL)))
2319 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2320 f->sym->name, &a->expr->where);
2324 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2325 provided for a procedure formal argument. */
2326 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2327 && a->expr->expr_type == EXPR_VARIABLE
2328 && f->sym->attr.flavor == FL_PROCEDURE)
2331 gfc_error ("Expected a procedure for argument '%s' at %L",
2332 f->sym->name, &a->expr->where);
2336 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2337 && a->expr->expr_type == EXPR_VARIABLE
2338 && a->expr->symtree->n.sym->as
2339 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2340 && (a->expr->ref == NULL
2341 || (a->expr->ref->type == REF_ARRAY
2342 && a->expr->ref->u.ar.type == AR_FULL)))
2345 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2346 " array at %L", f->sym->name, where);
2350 if (a->expr->expr_type != EXPR_NULL
2351 && compare_pointer (f->sym, a->expr) == 0)
2354 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2355 f->sym->name, &a->expr->where);
2359 if (a->expr->expr_type != EXPR_NULL
2360 && (gfc_option.allow_std & GFC_STD_F2008) == 0
2361 && compare_pointer (f->sym, a->expr) == 2)
2364 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2365 "pointer dummy '%s'", &a->expr->where,f->sym->name);
2370 /* Fortran 2008, C1242. */
2371 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2374 gfc_error ("Coindexed actual argument at %L to pointer "
2376 &a->expr->where, f->sym->name);
2380 /* Fortran 2008, 12.5.2.5 (no constraint). */
2381 if (a->expr->expr_type == EXPR_VARIABLE
2382 && f->sym->attr.intent != INTENT_IN
2383 && f->sym->attr.allocatable
2384 && gfc_is_coindexed (a->expr))
2387 gfc_error ("Coindexed actual argument at %L to allocatable "
2388 "dummy '%s' requires INTENT(IN)",
2389 &a->expr->where, f->sym->name);
2393 /* Fortran 2008, C1237. */
2394 if (a->expr->expr_type == EXPR_VARIABLE
2395 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2396 && gfc_is_coindexed (a->expr)
2397 && (a->expr->symtree->n.sym->attr.volatile_
2398 || a->expr->symtree->n.sym->attr.asynchronous))
2401 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2402 "at %L requires that dummy %s' has neither "
2403 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2408 /* Fortran 2008, 12.5.2.4 (no constraint). */
2409 if (a->expr->expr_type == EXPR_VARIABLE
2410 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2411 && gfc_is_coindexed (a->expr)
2412 && gfc_has_ultimate_allocatable (a->expr))
2415 gfc_error ("Coindexed actual argument at %L with allocatable "
2416 "ultimate component to dummy '%s' requires either VALUE "
2417 "or INTENT(IN)", &a->expr->where, f->sym->name);
2421 if (a->expr->expr_type != EXPR_NULL
2422 && compare_allocatable (f->sym, a->expr) == 0)
2425 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2426 f->sym->name, &a->expr->where);
2430 /* Check intent = OUT/INOUT for definable actual argument. */
2431 if ((f->sym->attr.intent == INTENT_OUT
2432 || f->sym->attr.intent == INTENT_INOUT))
2434 const char* context = (where
2435 ? _("actual argument to INTENT = OUT/INOUT")
2438 if (f->sym->attr.pointer
2439 && gfc_check_vardef_context (a->expr, true, false, context)
2442 if (gfc_check_vardef_context (a->expr, false, false, context)
2447 if ((f->sym->attr.intent == INTENT_OUT
2448 || f->sym->attr.intent == INTENT_INOUT
2449 || f->sym->attr.volatile_
2450 || f->sym->attr.asynchronous)
2451 && gfc_has_vector_subscript (a->expr))
2454 gfc_error ("Array-section actual argument with vector "
2455 "subscripts at %L is incompatible with INTENT(OUT), "
2456 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2457 "of the dummy argument '%s'",
2458 &a->expr->where, f->sym->name);
2462 /* C1232 (R1221) For an actual argument which is an array section or
2463 an assumed-shape array, the dummy argument shall be an assumed-
2464 shape array, if the dummy argument has the VOLATILE attribute. */
2466 if (f->sym->attr.volatile_
2467 && a->expr->symtree->n.sym->as
2468 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2469 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2472 gfc_error ("Assumed-shape actual argument at %L is "
2473 "incompatible with the non-assumed-shape "
2474 "dummy argument '%s' due to VOLATILE attribute",
2475 &a->expr->where,f->sym->name);
2479 if (f->sym->attr.volatile_
2480 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2481 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2484 gfc_error ("Array-section actual argument at %L is "
2485 "incompatible with the non-assumed-shape "
2486 "dummy argument '%s' due to VOLATILE attribute",
2487 &a->expr->where,f->sym->name);
2491 /* C1233 (R1221) For an actual argument which is a pointer array, the
2492 dummy argument shall be an assumed-shape or pointer array, if the
2493 dummy argument has the VOLATILE attribute. */
2495 if (f->sym->attr.volatile_
2496 && a->expr->symtree->n.sym->attr.pointer
2497 && a->expr->symtree->n.sym->as
2499 && (f->sym->as->type == AS_ASSUMED_SHAPE
2500 || f->sym->attr.pointer)))
2503 gfc_error ("Pointer-array actual argument at %L requires "
2504 "an assumed-shape or pointer-array dummy "
2505 "argument '%s' due to VOLATILE attribute",
2506 &a->expr->where,f->sym->name);
2517 /* Make sure missing actual arguments are optional. */
2519 for (f = formal; f; f = f->next, i++)
2521 if (new_arg[i] != NULL)
2526 gfc_error ("Missing alternate return spec in subroutine call "
2530 if (!f->sym->attr.optional)
2533 gfc_error ("Missing actual argument for argument '%s' at %L",
2534 f->sym->name, where);
2539 /* The argument lists are compatible. We now relink a new actual
2540 argument list with null arguments in the right places. The head
2541 of the list remains the head. */
2542 for (i = 0; i < n; i++)
2543 if (new_arg[i] == NULL)
2544 new_arg[i] = gfc_get_actual_arglist ();
2549 *new_arg[0] = *actual;
2553 new_arg[0] = new_arg[na];
2557 for (i = 0; i < n - 1; i++)
2558 new_arg[i]->next = new_arg[i + 1];
2560 new_arg[i]->next = NULL;
2562 if (*ap == NULL && n > 0)
2565 /* Note the types of omitted optional arguments. */
2566 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2567 if (a->expr == NULL && a->label == NULL)
2568 a->missing_arg_type = f->sym->ts.type;
2576 gfc_formal_arglist *f;
2577 gfc_actual_arglist *a;
2581 /* qsort comparison function for argument pairs, with the following
2583 - p->a->expr == NULL
2584 - p->a->expr->expr_type != EXPR_VARIABLE
2585 - growing p->a->expr->symbol. */
2588 pair_cmp (const void *p1, const void *p2)
2590 const gfc_actual_arglist *a1, *a2;
2592 /* *p1 and *p2 are elements of the to-be-sorted array. */
2593 a1 = ((const argpair *) p1)->a;
2594 a2 = ((const argpair *) p2)->a;
2603 if (a1->expr->expr_type != EXPR_VARIABLE)
2605 if (a2->expr->expr_type != EXPR_VARIABLE)
2609 if (a2->expr->expr_type != EXPR_VARIABLE)
2611 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2615 /* Given two expressions from some actual arguments, test whether they
2616 refer to the same expression. The analysis is conservative.
2617 Returning FAILURE will produce no warning. */
2620 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2622 const gfc_ref *r1, *r2;
2625 || e1->expr_type != EXPR_VARIABLE
2626 || e2->expr_type != EXPR_VARIABLE
2627 || e1->symtree->n.sym != e2->symtree->n.sym)
2630 /* TODO: improve comparison, see expr.c:show_ref(). */
2631 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2633 if (r1->type != r2->type)
2638 if (r1->u.ar.type != r2->u.ar.type)
2640 /* TODO: At the moment, consider only full arrays;
2641 we could do better. */
2642 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2647 if (r1->u.c.component != r2->u.c.component)
2655 gfc_internal_error ("compare_actual_expr(): Bad component code");
2664 /* Given formal and actual argument lists that correspond to one
2665 another, check that identical actual arguments aren't not
2666 associated with some incompatible INTENTs. */
2669 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2671 sym_intent f1_intent, f2_intent;
2672 gfc_formal_arglist *f1;
2673 gfc_actual_arglist *a1;
2676 gfc_try t = SUCCESS;
2679 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2681 if (f1 == NULL && a1 == NULL)
2683 if (f1 == NULL || a1 == NULL)
2684 gfc_internal_error ("check_some_aliasing(): List mismatch");
2689 p = XALLOCAVEC (argpair, n);
2691 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2697 qsort (p, n, sizeof (argpair), pair_cmp);
2699 for (i = 0; i < n; i++)
2702 || p[i].a->expr->expr_type != EXPR_VARIABLE
2703 || p[i].a->expr->ts.type == BT_PROCEDURE)
2705 f1_intent = p[i].f->sym->attr.intent;
2706 for (j = i + 1; j < n; j++)
2708 /* Expected order after the sort. */
2709 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2710 gfc_internal_error ("check_some_aliasing(): corrupted data");
2712 /* Are the expression the same? */
2713 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2715 f2_intent = p[j].f->sym->attr.intent;
2716 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2717 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2719 gfc_warning ("Same actual argument associated with INTENT(%s) "
2720 "argument '%s' and INTENT(%s) argument '%s' at %L",
2721 gfc_intent_string (f1_intent), p[i].f->sym->name,
2722 gfc_intent_string (f2_intent), p[j].f->sym->name,
2723 &p[i].a->expr->where);
2733 /* Given a symbol of a formal argument list and an expression,
2734 return nonzero if their intents are compatible, zero otherwise. */
2737 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2739 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2742 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2745 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2752 /* Given formal and actual argument lists that correspond to one
2753 another, check that they are compatible in the sense that intents
2754 are not mismatched. */
2757 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2759 sym_intent f_intent;
2761 for (;; f = f->next, a = a->next)
2763 if (f == NULL && a == NULL)
2765 if (f == NULL || a == NULL)
2766 gfc_internal_error ("check_intents(): List mismatch");
2768 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2771 f_intent = f->sym->attr.intent;
2773 if (!compare_parameter_intent(f->sym, a->expr))
2775 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2776 "specifies INTENT(%s)", &a->expr->where,
2777 gfc_intent_string (f_intent));
2781 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2783 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2785 gfc_error ("Procedure argument at %L is local to a PURE "
2786 "procedure and is passed to an INTENT(%s) argument",
2787 &a->expr->where, gfc_intent_string (f_intent));
2791 if (f->sym->attr.pointer)
2793 gfc_error ("Procedure argument at %L is local to a PURE "
2794 "procedure and has the POINTER attribute",
2800 /* Fortran 2008, C1283. */
2801 if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2803 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2805 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2806 "is passed to an INTENT(%s) argument",
2807 &a->expr->where, gfc_intent_string (f_intent));
2811 if (f->sym->attr.pointer)
2813 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2814 "is passed to a POINTER dummy argument",
2820 /* F2008, Section 12.5.2.4. */
2821 if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2822 && gfc_is_coindexed (a->expr))
2824 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2825 "polymorphic dummy argument '%s'",
2826 &a->expr->where, f->sym->name);
2835 /* Check how a procedure is used against its interface. If all goes
2836 well, the actual argument list will also end up being properly
2840 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2843 /* Warn about calls with an implicit interface. Special case
2844 for calling a ISO_C_BINDING becase c_loc and c_funloc
2845 are pseudo-unknown. Additionally, warn about procedures not
2846 explicitly declared at all if requested. */
2847 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2849 if (gfc_option.warn_implicit_interface)
2850 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2852 else if (gfc_option.warn_implicit_procedure
2853 && sym->attr.proc == PROC_UNKNOWN)
2854 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2858 if (sym->attr.if_source == IFSRC_UNKNOWN)
2860 gfc_actual_arglist *a;
2862 if (sym->attr.pointer)
2864 gfc_error("The pointer object '%s' at %L must have an explicit "
2865 "function interface or be declared as array",
2870 if (sym->attr.allocatable && !sym->attr.external)
2872 gfc_error("The allocatable object '%s' at %L must have an explicit "
2873 "function interface or be declared as array",
2878 if (sym->attr.allocatable)
2880 gfc_error("Allocatable function '%s' at %L must have an explicit "
2881 "function interface", sym->name, where);
2885 for (a = *ap; a; a = a->next)
2887 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2888 if (a->name != NULL && a->name[0] != '%')
2890 gfc_error("Keyword argument requires explicit interface "
2891 "for procedure '%s' at %L", sym->name, &a->expr->where);
2895 /* F2008, C1303 and C1304. */
2897 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
2898 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2899 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2900 || gfc_expr_attr (a->expr).lock_comp))
2902 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
2903 "component at %L requires an explicit interface for "
2904 "procedure '%s'", &a->expr->where, sym->name);
2908 if (a->expr && a->expr->expr_type == EXPR_NULL
2909 && a->expr->ts.type == BT_UNKNOWN)
2911 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
2919 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2922 check_intents (sym->formal, *ap);
2923 if (gfc_option.warn_aliasing)
2924 check_some_aliasing (sym->formal, *ap);
2928 /* Check how a procedure pointer component is used against its interface.
2929 If all goes well, the actual argument list will also end up being properly
2930 sorted. Completely analogous to gfc_procedure_use. */
2933 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2936 /* Warn about calls with an implicit interface. Special case
2937 for calling a ISO_C_BINDING becase c_loc and c_funloc
2938 are pseudo-unknown. */
2939 if (gfc_option.warn_implicit_interface
2940 && comp->attr.if_source == IFSRC_UNKNOWN
2941 && !comp->attr.is_iso_c)
2942 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2943 "interface at %L", comp->name, where);
2945 if (comp->attr.if_source == IFSRC_UNKNOWN)
2947 gfc_actual_arglist *a;
2948 for (a = *ap; a; a = a->next)
2950 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2951 if (a->name != NULL && a->name[0] != '%')
2953 gfc_error("Keyword argument requires explicit interface "
2954 "for procedure pointer component '%s' at %L",
2955 comp->name, &a->expr->where);
2963 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2966 check_intents (comp->formal, *ap);
2967 if (gfc_option.warn_aliasing)
2968 check_some_aliasing (comp->formal, *ap);
2972 /* Try if an actual argument list matches the formal list of a symbol,
2973 respecting the symbol's attributes like ELEMENTAL. This is used for
2974 GENERIC resolution. */
2977 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2981 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2983 r = !sym->attr.elemental;
2984 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2986 check_intents (sym->formal, *args);
2987 if (gfc_option.warn_aliasing)
2988 check_some_aliasing (sym->formal, *args);
2996 /* Given an interface pointer and an actual argument list, search for
2997 a formal argument list that matches the actual. If found, returns
2998 a pointer to the symbol of the correct interface. Returns NULL if
3002 gfc_search_interface (gfc_interface *intr, int sub_flag,
3003 gfc_actual_arglist **ap)
3005 gfc_symbol *elem_sym = NULL;
3006 gfc_symbol *null_sym = NULL;
3007 locus null_expr_loc;
3008 gfc_actual_arglist *a;
3009 bool has_null_arg = false;
3011 for (a = *ap; a; a = a->next)
3012 if (a->expr && a->expr->expr_type == EXPR_NULL
3013 && a->expr->ts.type == BT_UNKNOWN)
3015 has_null_arg = true;
3016 null_expr_loc = a->expr->where;
3020 for (; intr; intr = intr->next)
3022 if (sub_flag && intr->sym->attr.function)
3024 if (!sub_flag && intr->sym->attr.subroutine)
3027 if (gfc_arglist_matches_symbol (ap, intr->sym))
3029 if (has_null_arg && null_sym)
3031 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3032 "between specific functions %s and %s",
3033 &null_expr_loc, null_sym->name, intr->sym->name);
3036 else if (has_null_arg)
3038 null_sym = intr->sym;
3042 /* Satisfy 12.4.4.1 such that an elemental match has lower
3043 weight than a non-elemental match. */
3044 if (intr->sym->attr.elemental)
3046 elem_sym = intr->sym;
3056 return elem_sym ? elem_sym : NULL;
3060 /* Do a brute force recursive search for a symbol. */
3062 static gfc_symtree *
3063 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3067 if (root->n.sym == sym)
3072 st = find_symtree0 (root->left, sym);
3073 if (root->right && ! st)
3074 st = find_symtree0 (root->right, sym);
3079 /* Find a symtree for a symbol. */
3082 gfc_find_sym_in_symtree (gfc_symbol *sym)
3087 /* First try to find it by name. */
3088 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3089 if (st && st->n.sym == sym)
3092 /* If it's been renamed, resort to a brute-force search. */
3093 /* TODO: avoid having to do this search. If the symbol doesn't exist
3094 in the symtree for the current namespace, it should probably be added. */
3095 for (ns = gfc_current_ns; ns; ns = ns->parent)
3097 st = find_symtree0 (ns->sym_root, sym);
3101 gfc_internal_error ("Unable to find symbol %s", sym->name);
3106 /* See if the arglist to an operator-call contains a derived-type argument
3107 with a matching type-bound operator. If so, return the matching specific
3108 procedure defined as operator-target as well as the base-object to use
3109 (which is the found derived-type argument with operator). The generic
3110 name, if any, is transmitted to the final expression via 'gname'. */
3112 static gfc_typebound_proc*
3113 matching_typebound_op (gfc_expr** tb_base,
3114 gfc_actual_arglist* args,
3115 gfc_intrinsic_op op, const char* uop,
3116 const char ** gname)
3118 gfc_actual_arglist* base;
3120 for (base = args; base; base = base->next)
3121 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3123 gfc_typebound_proc* tb;
3124 gfc_symbol* derived;
3127 if (base->expr->ts.type == BT_CLASS)
3129 if (!gfc_expr_attr (base->expr).class_ok)
3131 derived = CLASS_DATA (base->expr)->ts.u.derived;
3134 derived = base->expr->ts.u.derived;
3136 if (op == INTRINSIC_USER)
3138 gfc_symtree* tb_uop;
3141 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3150 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3153 /* This means we hit a PRIVATE operator which is use-associated and
3154 should thus not be seen. */
3155 if (result == FAILURE)
3158 /* Look through the super-type hierarchy for a matching specific
3160 for (; tb; tb = tb->overridden)
3164 gcc_assert (tb->is_generic);
3165 for (g = tb->u.generic; g; g = g->next)
3168 gfc_actual_arglist* argcopy;
3171 gcc_assert (g->specific);
3172 if (g->specific->error)
3175 target = g->specific->u.specific->n.sym;
3177 /* Check if this arglist matches the formal. */
3178 argcopy = gfc_copy_actual_arglist (args);
3179 matches = gfc_arglist_matches_symbol (&argcopy, target);
3180 gfc_free_actual_arglist (argcopy);
3182 /* Return if we found a match. */
3185 *tb_base = base->expr;
3186 *gname = g->specific_st->name;
3197 /* For the 'actual arglist' of an operator call and a specific typebound
3198 procedure that has been found the target of a type-bound operator, build the
3199 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3200 type-bound procedures rather than resolving type-bound operators 'directly'
3201 so that we can reuse the existing logic. */
3204 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3205 gfc_expr* base, gfc_typebound_proc* target,
3208 e->expr_type = EXPR_COMPCALL;
3209 e->value.compcall.tbp = target;
3210 e->value.compcall.name = gname ? gname : "$op";
3211 e->value.compcall.actual = actual;
3212 e->value.compcall.base_object = base;
3213 e->value.compcall.ignore_pass = 1;
3214 e->value.compcall.assign = 0;
3218 /* This subroutine is called when an expression is being resolved.
3219 The expression node in question is either a user defined operator
3220 or an intrinsic operator with arguments that aren't compatible
3221 with the operator. This subroutine builds an actual argument list
3222 corresponding to the operands, then searches for a compatible
3223 interface. If one is found, the expression node is replaced with
3224 the appropriate function call. We use the 'match' enum to specify
3225 whether a replacement has been made or not, or if an error occurred. */
3228 gfc_extend_expr (gfc_expr *e)
3230 gfc_actual_arglist *actual;
3239 actual = gfc_get_actual_arglist ();
3240 actual->expr = e->value.op.op1;
3244 if (e->value.op.op2 != NULL)
3246 actual->next = gfc_get_actual_arglist ();
3247 actual->next->expr = e->value.op.op2;
3250 i = fold_unary_intrinsic (e->value.op.op);
3252 if (i == INTRINSIC_USER)
3254 for (ns = gfc_current_ns; ns; ns = ns->parent)
3256 uop = gfc_find_uop (e->value.op.uop->name, ns);
3260 sym = gfc_search_interface (uop->op, 0, &actual);
3267 for (ns = gfc_current_ns; ns; ns = ns->parent)
3269 /* Due to the distinction between '==' and '.eq.' and friends, one has
3270 to check if either is defined. */
3273 #define CHECK_OS_COMPARISON(comp) \
3274 case INTRINSIC_##comp: \
3275 case INTRINSIC_##comp##_OS: \
3276 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3278 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3280 CHECK_OS_COMPARISON(EQ)
3281 CHECK_OS_COMPARISON(NE)
3282 CHECK_OS_COMPARISON(GT)
3283 CHECK_OS_COMPARISON(GE)
3284 CHECK_OS_COMPARISON(LT)
3285 CHECK_OS_COMPARISON(LE)
3286 #undef CHECK_OS_COMPARISON
3289 sym = gfc_search_interface (ns->op[i], 0, &actual);
3297 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3298 found rather than just taking the first one and not checking further. */
3302 gfc_typebound_proc* tbo;
3305 /* See if we find a matching type-bound operator. */
3306 if (i == INTRINSIC_USER)
3307 tbo = matching_typebound_op (&tb_base, actual,
3308 i, e->value.op.uop->name, &gname);
3312 #define CHECK_OS_COMPARISON(comp) \
3313 case INTRINSIC_##comp: \
3314 case INTRINSIC_##comp##_OS: \
3315 tbo = matching_typebound_op (&tb_base, actual, \
3316 INTRINSIC_##comp, NULL, &gname); \
3318 tbo = matching_typebound_op (&tb_base, actual, \
3319 INTRINSIC_##comp##_OS, NULL, &gname); \
3321 CHECK_OS_COMPARISON(EQ)
3322 CHECK_OS_COMPARISON(NE)
3323 CHECK_OS_COMPARISON(GT)
3324 CHECK_OS_COMPARISON(GE)
3325 CHECK_OS_COMPARISON(LT)
3326 CHECK_OS_COMPARISON(LE)
3327 #undef CHECK_OS_COMPARISON
3330 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3334 /* If there is a matching typebound-operator, replace the expression with
3335 a call to it and succeed. */
3340 gcc_assert (tb_base);
3341 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3343 result = gfc_resolve_expr (e);
3344 if (result == FAILURE)
3350 /* Don't use gfc_free_actual_arglist(). */
3351 free (actual->next);
3357 /* Change the expression node to a function call. */
3358 e->expr_type = EXPR_FUNCTION;
3359 e->symtree = gfc_find_sym_in_symtree (sym);
3360 e->value.function.actual = actual;
3361 e->value.function.esym = NULL;
3362 e->value.function.isym = NULL;
3363 e->value.function.name = NULL;
3364 e->user_operator = 1;
3366 if (gfc_resolve_expr (e) == FAILURE)
3373 /* Tries to replace an assignment code node with a subroutine call to
3374 the subroutine associated with the assignment operator. Return
3375 SUCCESS if the node was replaced. On FAILURE, no error is
3379 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3381 gfc_actual_arglist *actual;
3382 gfc_expr *lhs, *rhs;
3391 /* Don't allow an intrinsic assignment to be replaced. */
3392 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3393 && (rhs->rank == 0 || rhs->rank == lhs->rank)
3394 && (lhs->ts.type == rhs->ts.type
3395 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3398 actual = gfc_get_actual_arglist ();
3401 actual->next = gfc_get_actual_arglist ();
3402 actual->next->expr = rhs;
3406 for (; ns; ns = ns->parent)
3408 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3413 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3417 gfc_typebound_proc* tbo;
3420 /* See if we find a matching type-bound assignment. */
3421 tbo = matching_typebound_op (&tb_base, actual,
3422 INTRINSIC_ASSIGN, NULL, &gname);
3424 /* If there is one, replace the expression with a call to it and
3428 gcc_assert (tb_base);
3429 c->expr1 = gfc_get_expr ();
3430 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3431 c->expr1->value.compcall.assign = 1;
3432 c->expr1->where = c->loc;
3434 c->op = EXEC_COMPCALL;
3436 /* c is resolved from the caller, so no need to do it here. */
3441 free (actual->next);
3446 /* Replace the assignment with the call. */
3447 c->op = EXEC_ASSIGN_CALL;
3448 c->symtree = gfc_find_sym_in_symtree (sym);
3451 c->ext.actual = actual;
3457 /* Make sure that the interface just parsed is not already present in
3458 the given interface list. Ambiguity isn't checked yet since module
3459 procedures can be present without interfaces. */
3462 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
3466 for (ip = base; ip; ip = ip->next)
3468 if (ip->sym == new_sym)
3470 gfc_error ("Entity '%s' at %C is already present in the interface",
3480 /* Add a symbol to the current interface. */
3483 gfc_add_interface (gfc_symbol *new_sym)
3485 gfc_interface **head, *intr;
3489 switch (current_interface.type)
3491 case INTERFACE_NAMELESS:
3492 case INTERFACE_ABSTRACT:
3495 case INTERFACE_INTRINSIC_OP:
3496 for (ns = current_interface.ns; ns; ns = ns->parent)
3497 switch (current_interface.op)
3500 case INTRINSIC_EQ_OS:
3501 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
3502 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
3507 case INTRINSIC_NE_OS:
3508 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
3509 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
3514 case INTRINSIC_GT_OS:
3515 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
3516 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
3521 case INTRINSIC_GE_OS:
3522 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
3523 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
3528 case INTRINSIC_LT_OS:
3529 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
3530 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
3535 case INTRINSIC_LE_OS:
3536 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
3537 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3542 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3546 head = ¤t_interface.ns->op[current_interface.op];
3549 case INTERFACE_GENERIC:
3550 for (ns = current_interface.ns; ns; ns = ns->parent)
3552 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3556 if (check_new_interface (sym->generic, new_sym) == FAILURE)
3560 head = ¤t_interface.sym->generic;
3563 case INTERFACE_USER_OP:
3564 if (check_new_interface (current_interface.uop->op, new_sym)
3568 head = ¤t_interface.uop->op;
3572 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3575 intr = gfc_get_interface ();
3576 intr->sym = new_sym;
3577 intr->where = gfc_current_locus;
3587 gfc_current_interface_head (void)
3589 switch (current_interface.type)
3591 case INTERFACE_INTRINSIC_OP:
3592 return current_interface.ns->op[current_interface.op];
3595 case INTERFACE_GENERIC:
3596 return current_interface.sym->generic;
3599 case INTERFACE_USER_OP:
3600 return current_interface.uop->op;
3610 gfc_set_current_interface_head (gfc_interface *i)
3612 switch (current_interface.type)
3614 case INTERFACE_INTRINSIC_OP:
3615 current_interface.ns->op[current_interface.op] = i;
3618 case INTERFACE_GENERIC:
3619 current_interface.sym->generic = i;
3622 case INTERFACE_USER_OP:
3623 current_interface.uop->op = i;
3632 /* Gets rid of a formal argument list. We do not free symbols.
3633 Symbols are freed when a namespace is freed. */
3636 gfc_free_formal_arglist (gfc_formal_arglist *p)
3638 gfc_formal_arglist *q;
3648 /* Check that it is ok for the type-bound procedure 'proc' to override the
3649 procedure 'old', cf. F08:4.5.7.3. */
3652 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3655 const gfc_symbol *proc_target, *old_target;
3656 unsigned proc_pass_arg, old_pass_arg, argpos;
3657 gfc_formal_arglist *proc_formal, *old_formal;
3661 /* This procedure should only be called for non-GENERIC proc. */
3662 gcc_assert (!proc->n.tb->is_generic);
3664 /* If the overwritten procedure is GENERIC, this is an error. */
3665 if (old->n.tb->is_generic)
3667 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3668 old->name, &proc->n.tb->where);
3672 where = proc->n.tb->where;
3673 proc_target = proc->n.tb->u.specific->n.sym;
3674 old_target = old->n.tb->u.specific->n.sym;
3676 /* Check that overridden binding is not NON_OVERRIDABLE. */
3677 if (old->n.tb->non_overridable)
3679 gfc_error ("'%s' at %L overrides a procedure binding declared"
3680 " NON_OVERRIDABLE", proc->name, &where);
3684 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3685 if (!old->n.tb->deferred && proc->n.tb->deferred)
3687 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3688 " non-DEFERRED binding", proc->name, &where);
3692 /* If the overridden binding is PURE, the overriding must be, too. */
3693 if (old_target->attr.pure && !proc_target->attr.pure)
3695 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3696 proc->name, &where);
3700 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3701 is not, the overriding must not be either. */
3702 if (old_target->attr.elemental && !proc_target->attr.elemental)
3704 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3705 " ELEMENTAL", proc->name, &where);
3708 if (!old_target->attr.elemental && proc_target->attr.elemental)
3710 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3711 " be ELEMENTAL, either", proc->name, &where);
3715 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3717 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
3719 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3720 " SUBROUTINE", proc->name, &where);
3724 /* If the overridden binding is a FUNCTION, the overriding must also be a
3725 FUNCTION and have the same characteristics. */
3726 if (old_target->attr.function)
3728 if (!proc_target->attr.function)
3730 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3731 " FUNCTION", proc->name, &where);
3735 /* FIXME: Do more comprehensive checking (including, for instance, the
3737 gcc_assert (proc_target->result && old_target->result);
3738 if (!compare_type_rank (proc_target->result, old_target->result))
3740 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3741 " matching result types and ranks", proc->name, &where);
3745 /* Check string length. */
3746 if (proc_target->result->ts.type == BT_CHARACTER
3747 && proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
3749 int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
3750 old_target->result->ts.u.cl->length);
3756 gfc_error ("Character length mismatch between '%s' at '%L' and "
3757 "overridden FUNCTION", proc->name, &where);
3761 gfc_warning ("Possible character length mismatch between '%s' at"
3762 " '%L' and overridden FUNCTION", proc->name, &where);
3769 gfc_internal_error ("gfc_check_typebound_override: Unexpected "
3770 "result %i of gfc_dep_compare_expr", compval);
3776 /* If the overridden binding is PUBLIC, the overriding one must not be
3778 if (old->n.tb->access == ACCESS_PUBLIC
3779 && proc->n.tb->access == ACCESS_PRIVATE)
3781 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3782 " PRIVATE", proc->name, &where);
3786 /* Compare the formal argument lists of both procedures. This is also abused
3787 to find the position of the passed-object dummy arguments of both
3788 bindings as at least the overridden one might not yet be resolved and we
3789 need those positions in the check below. */
3790 proc_pass_arg = old_pass_arg = 0;
3791 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
3793 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
3796 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
3797 proc_formal && old_formal;
3798 proc_formal = proc_formal->next, old_formal = old_formal->next)
3800 if (proc->n.tb->pass_arg
3801 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
3802 proc_pass_arg = argpos;
3803 if (old->n.tb->pass_arg
3804 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
3805 old_pass_arg = argpos;
3807 /* Check that the names correspond. */
3808 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
3810 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3811 " to match the corresponding argument of the overridden"
3812 " procedure", proc_formal->sym->name, proc->name, &where,
3813 old_formal->sym->name);
3817 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
3818 if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
3819 check_type, err, sizeof(err)) == FAILURE)
3821 gfc_error ("Argument mismatch for the overriding procedure "
3822 "'%s' at %L: %s", proc->name, &where, err);
3828 if (proc_formal || old_formal)
3830 gfc_error ("'%s' at %L must have the same number of formal arguments as"
3831 " the overridden procedure", proc->name, &where);
3835 /* If the overridden binding is NOPASS, the overriding one must also be
3837 if (old->n.tb->nopass && !proc->n.tb->nopass)
3839 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3840 " NOPASS", proc->name, &where);
3844 /* If the overridden binding is PASS(x), the overriding one must also be
3845 PASS and the passed-object dummy arguments must correspond. */
3846 if (!old->n.tb->nopass)
3848 if (proc->n.tb->nopass)
3850 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3851 " PASS", proc->name, &where);
3855 if (proc_pass_arg != old_pass_arg)
3857 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3858 " the same position as the passed-object dummy argument of"
3859 " the overridden procedure", proc->name, &where);