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. */
73 /* The current_interface structure holds information about the
74 interface currently being parsed. This structure is saved and
75 restored during recursive interfaces. */
77 gfc_interface_info current_interface;
80 /* Free a singly linked list of gfc_interface structures. */
83 gfc_free_interface (gfc_interface *intr)
87 for (; intr; intr = next)
95 /* Change the operators unary plus and minus into binary plus and
96 minus respectively, leaving the rest unchanged. */
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op)
103 case INTRINSIC_UPLUS:
106 case INTRINSIC_UMINUS:
107 op = INTRINSIC_MINUS;
117 /* Match a generic specification. Depending on which type of
118 interface is found, the 'name' or 'op' pointers may be set.
119 This subroutine doesn't return MATCH_NO. */
122 gfc_match_generic_spec (interface_type *type,
124 gfc_intrinsic_op *op)
126 char buffer[GFC_MAX_SYMBOL_LEN + 1];
130 if (gfc_match (" assignment ( = )") == MATCH_YES)
132 *type = INTERFACE_INTRINSIC_OP;
133 *op = INTRINSIC_ASSIGN;
137 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
139 *type = INTERFACE_INTRINSIC_OP;
140 *op = fold_unary_intrinsic (i);
144 *op = INTRINSIC_NONE;
145 if (gfc_match (" operator ( ") == MATCH_YES)
147 m = gfc_match_defined_op_name (buffer, 1);
153 m = gfc_match_char (')');
159 strcpy (name, buffer);
160 *type = INTERFACE_USER_OP;
164 if (gfc_match_name (buffer) == MATCH_YES)
166 strcpy (name, buffer);
167 *type = INTERFACE_GENERIC;
171 *type = INTERFACE_NAMELESS;
175 gfc_error ("Syntax error in generic specification at %C");
180 /* Match one of the five F95 forms of an interface statement. The
181 matcher for the abstract interface follows. */
184 gfc_match_interface (void)
186 char name[GFC_MAX_SYMBOL_LEN + 1];
192 m = gfc_match_space ();
194 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
197 /* If we're not looking at the end of the statement now, or if this
198 is not a nameless interface but we did not see a space, punt. */
199 if (gfc_match_eos () != MATCH_YES
200 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
202 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
207 current_interface.type = type;
211 case INTERFACE_GENERIC:
212 if (gfc_get_symbol (name, NULL, &sym))
215 if (!sym->attr.generic
216 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
221 gfc_error ("Dummy procedure '%s' at %C cannot have a "
222 "generic interface", sym->name);
226 current_interface.sym = gfc_new_block = sym;
229 case INTERFACE_USER_OP:
230 current_interface.uop = gfc_get_uop (name);
233 case INTERFACE_INTRINSIC_OP:
234 current_interface.op = op;
237 case INTERFACE_NAMELESS:
238 case INTERFACE_ABSTRACT:
247 /* Match a F2003 abstract interface. */
250 gfc_match_abstract_interface (void)
254 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
258 m = gfc_match_eos ();
262 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
266 current_interface.type = INTERFACE_ABSTRACT;
272 /* Match the different sort of generic-specs that can be present after
273 the END INTERFACE itself. */
276 gfc_match_end_interface (void)
278 char name[GFC_MAX_SYMBOL_LEN + 1];
283 m = gfc_match_space ();
285 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
288 /* If we're not looking at the end of the statement now, or if this
289 is not a nameless interface but we did not see a space, punt. */
290 if (gfc_match_eos () != MATCH_YES
291 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
293 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
300 switch (current_interface.type)
302 case INTERFACE_NAMELESS:
303 case INTERFACE_ABSTRACT:
304 if (type != INTERFACE_NAMELESS)
306 gfc_error ("Expected a nameless interface at %C");
312 case INTERFACE_INTRINSIC_OP:
313 if (type != current_interface.type || op != current_interface.op)
316 if (current_interface.op == INTRINSIC_ASSIGN)
319 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
324 s1 = gfc_op2string (current_interface.op);
325 s2 = gfc_op2string (op);
327 /* The following if-statements are used to enforce C1202
329 if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
330 || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
332 if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
333 || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
335 if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
336 || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
338 if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
339 || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
341 if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
342 || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
344 if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
345 || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
349 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
350 "but got %s", s1, s2);
357 case INTERFACE_USER_OP:
358 /* Comparing the symbol node names is OK because only use-associated
359 symbols can be renamed. */
360 if (type != current_interface.type
361 || strcmp (current_interface.uop->name, name) != 0)
363 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
364 current_interface.uop->name);
370 case INTERFACE_GENERIC:
371 if (type != current_interface.type
372 || strcmp (current_interface.sym->name, name) != 0)
374 gfc_error ("Expecting 'END INTERFACE %s' at %C",
375 current_interface.sym->name);
386 /* Compare two derived types using the criteria in 4.4.2 of the standard,
387 recursing through gfc_compare_types for the components. */
390 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
392 gfc_component *dt1, *dt2;
394 if (derived1 == derived2)
397 /* Special case for comparing derived types across namespaces. If the
398 true names and module names are the same and the module name is
399 nonnull, then they are equal. */
400 if (derived1 != NULL && derived2 != NULL
401 && strcmp (derived1->name, derived2->name) == 0
402 && derived1->module != NULL && derived2->module != NULL
403 && strcmp (derived1->module, derived2->module) == 0)
406 /* Compare type via the rules of the standard. Both types must have
407 the SEQUENCE attribute to be equal. */
409 if (strcmp (derived1->name, derived2->name))
412 if (derived1->component_access == ACCESS_PRIVATE
413 || derived2->component_access == ACCESS_PRIVATE)
416 if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
419 dt1 = derived1->components;
420 dt2 = derived2->components;
422 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
423 simple test can speed things up. Otherwise, lots of things have to
427 if (strcmp (dt1->name, dt2->name) != 0)
430 if (dt1->attr.access != dt2->attr.access)
433 if (dt1->attr.pointer != dt2->attr.pointer)
436 if (dt1->attr.dimension != dt2->attr.dimension)
439 if (dt1->attr.allocatable != dt2->attr.allocatable)
442 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
445 /* Make sure that link lists do not put this function into an
446 endless recursive loop! */
447 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
448 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
449 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
452 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
453 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
456 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
457 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
463 if (dt1 == NULL && dt2 == NULL)
465 if (dt1 == NULL || dt2 == NULL)
473 /* Compare two typespecs, recursively if necessary. */
476 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
478 /* See if one of the typespecs is a BT_VOID, which is what is being used
479 to allow the funcs like c_f_pointer to accept any pointer type.
480 TODO: Possibly should narrow this to just the one typespec coming in
481 that is for the formal arg, but oh well. */
482 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
485 if (ts1->type != ts2->type
486 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
487 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
489 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
490 return (ts1->kind == ts2->kind);
492 /* Compare derived types. */
493 if (gfc_type_compatible (ts1, ts2))
496 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
500 /* Given two symbols that are formal arguments, compare their ranks
501 and types. Returns nonzero if they have the same rank and type,
505 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
509 r1 = (s1->as != NULL) ? s1->as->rank : 0;
510 r2 = (s2->as != NULL) ? s2->as->rank : 0;
513 return 0; /* Ranks differ. */
515 return gfc_compare_types (&s1->ts, &s2->ts);
519 /* Given two symbols that are formal arguments, compare their types
520 and rank and their formal interfaces if they are both dummy
521 procedures. Returns nonzero if the same, zero if different. */
524 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
526 if (s1 == NULL || s2 == NULL)
527 return s1 == s2 ? 1 : 0;
532 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
533 return compare_type_rank (s1, s2);
535 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
538 /* At this point, both symbols are procedures. It can happen that
539 external procedures are compared, where one is identified by usage
540 to be a function or subroutine but the other is not. Check TKR
541 nonetheless for these cases. */
542 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
543 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
545 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
546 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
548 /* Now the type of procedure has been identified. */
549 if (s1->attr.function != s2->attr.function
550 || s1->attr.subroutine != s2->attr.subroutine)
553 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
556 /* Originally, gfortran recursed here to check the interfaces of passed
557 procedures. This is explicitly not required by the standard. */
562 /* Given a formal argument list and a keyword name, search the list
563 for that keyword. Returns the correct symbol node if found, NULL
567 find_keyword_arg (const char *name, gfc_formal_arglist *f)
569 for (; f; f = f->next)
570 if (strcmp (f->sym->name, name) == 0)
577 /******** Interface checking subroutines **********/
580 /* Given an operator interface and the operator, make sure that all
581 interfaces for that operator are legal. */
584 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
587 gfc_formal_arglist *formal;
590 int args, r1, r2, k1, k2;
595 t1 = t2 = BT_UNKNOWN;
596 i1 = i2 = INTENT_UNKNOWN;
600 for (formal = sym->formal; formal; formal = formal->next)
602 gfc_symbol *fsym = formal->sym;
605 gfc_error ("Alternate return cannot appear in operator "
606 "interface at %L", &sym->declared_at);
612 i1 = fsym->attr.intent;
613 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
619 i2 = fsym->attr.intent;
620 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
626 /* Only +, - and .not. can be unary operators.
627 .not. cannot be a binary operator. */
628 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
629 && op != INTRINSIC_MINUS
630 && op != INTRINSIC_NOT)
631 || (args == 2 && op == INTRINSIC_NOT))
633 gfc_error ("Operator interface at %L has the wrong number of arguments",
638 /* Check that intrinsics are mapped to functions, except
639 INTRINSIC_ASSIGN which should map to a subroutine. */
640 if (op == INTRINSIC_ASSIGN)
642 if (!sym->attr.subroutine)
644 gfc_error ("Assignment operator interface at %L must be "
645 "a SUBROUTINE", &sym->declared_at);
650 gfc_error ("Assignment operator interface at %L must have "
651 "two arguments", &sym->declared_at);
655 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
656 - First argument an array with different rank than second,
657 - First argument is a scalar and second an array,
658 - Types and kinds do not conform, or
659 - First argument is of derived type. */
660 if (sym->formal->sym->ts.type != BT_DERIVED
661 && sym->formal->sym->ts.type != BT_CLASS
662 && (r2 == 0 || r1 == r2)
663 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
664 || (gfc_numeric_ts (&sym->formal->sym->ts)
665 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
667 gfc_error ("Assignment operator interface at %L must not redefine "
668 "an INTRINSIC type assignment", &sym->declared_at);
674 if (!sym->attr.function)
676 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
682 /* Check intents on operator interfaces. */
683 if (op == INTRINSIC_ASSIGN)
685 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
687 gfc_error ("First argument of defined assignment at %L must be "
688 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
694 gfc_error ("Second argument of defined assignment at %L must be "
695 "INTENT(IN)", &sym->declared_at);
703 gfc_error ("First argument of operator interface at %L must be "
704 "INTENT(IN)", &sym->declared_at);
708 if (args == 2 && i2 != INTENT_IN)
710 gfc_error ("Second argument of operator interface at %L must be "
711 "INTENT(IN)", &sym->declared_at);
716 /* From now on, all we have to do is check that the operator definition
717 doesn't conflict with an intrinsic operator. The rules for this
718 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
719 as well as 12.3.2.1.1 of Fortran 2003:
721 "If the operator is an intrinsic-operator (R310), the number of
722 function arguments shall be consistent with the intrinsic uses of
723 that operator, and the types, kind type parameters, or ranks of the
724 dummy arguments shall differ from those required for the intrinsic
725 operation (7.1.2)." */
727 #define IS_NUMERIC_TYPE(t) \
728 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
730 /* Unary ops are easy, do them first. */
731 if (op == INTRINSIC_NOT)
733 if (t1 == BT_LOGICAL)
739 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
741 if (IS_NUMERIC_TYPE (t1))
747 /* Character intrinsic operators have same character kind, thus
748 operator definitions with operands of different character kinds
750 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
753 /* Intrinsic operators always perform on arguments of same rank,
754 so different ranks is also always safe. (rank == 0) is an exception
755 to that, because all intrinsic operators are elemental. */
756 if (r1 != r2 && r1 != 0 && r2 != 0)
762 case INTRINSIC_EQ_OS:
764 case INTRINSIC_NE_OS:
765 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
770 case INTRINSIC_MINUS:
771 case INTRINSIC_TIMES:
772 case INTRINSIC_DIVIDE:
773 case INTRINSIC_POWER:
774 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
779 case INTRINSIC_GT_OS:
781 case INTRINSIC_GE_OS:
783 case INTRINSIC_LT_OS:
785 case INTRINSIC_LE_OS:
786 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
788 if ((t1 == BT_INTEGER || t1 == BT_REAL)
789 && (t2 == BT_INTEGER || t2 == BT_REAL))
793 case INTRINSIC_CONCAT:
794 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
802 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
812 #undef IS_NUMERIC_TYPE
815 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
821 /* Given a pair of formal argument lists, we see if the two lists can
822 be distinguished by counting the number of nonoptional arguments of
823 a given type/rank in f1 and seeing if there are less then that
824 number of those arguments in f2 (including optional arguments).
825 Since this test is asymmetric, it has to be called twice to make it
826 symmetric. Returns nonzero if the argument lists are incompatible
827 by this test. This subroutine implements rule 1 of section
828 14.1.2.3 in the Fortran 95 standard. */
831 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
833 int rc, ac1, ac2, i, j, k, n1;
834 gfc_formal_arglist *f;
847 for (f = f1; f; f = f->next)
850 /* Build an array of integers that gives the same integer to
851 arguments of the same type/rank. */
852 arg = XCNEWVEC (arginfo, n1);
855 for (i = 0; i < n1; i++, f = f->next)
863 for (i = 0; i < n1; i++)
865 if (arg[i].flag != -1)
868 if (arg[i].sym && arg[i].sym->attr.optional)
869 continue; /* Skip optional arguments. */
873 /* Find other nonoptional arguments of the same type/rank. */
874 for (j = i + 1; j < n1; j++)
875 if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
876 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
877 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
883 /* Now loop over each distinct type found in f1. */
887 for (i = 0; i < n1; i++)
889 if (arg[i].flag != k)
893 for (j = i + 1; j < n1; j++)
894 if (arg[j].flag == k)
897 /* Count the number of arguments in f2 with that type, including
898 those that are optional. */
901 for (f = f2; f; f = f->next)
902 if (compare_type_rank_if (arg[i].sym, f->sym)
903 || compare_type_rank_if (f->sym, arg[i].sym))
921 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
922 Returns zero if no argument is found that satisfies rule 2, nonzero
925 This test is also not symmetric in f1 and f2 and must be called
926 twice. This test finds problems caused by sorting the actual
927 argument list with keywords. For example:
931 INTEGER :: A ; REAL :: B
935 INTEGER :: A ; REAL :: B
939 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
942 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
944 gfc_formal_arglist *f2_save, *g;
951 if (f1->sym->attr.optional)
954 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
955 || compare_type_rank (f2->sym, f1->sym)))
958 /* Now search for a disambiguating keyword argument starting at
959 the current non-match. */
960 for (g = f1; g; g = g->next)
962 if (g->sym->attr.optional)
965 sym = find_keyword_arg (g->sym->name, f2_save);
966 if (sym == NULL || !compare_type_rank (g->sym, sym))
980 /* 'Compare' two formal interfaces associated with a pair of symbols.
981 We return nonzero if there exists an actual argument list that
982 would be ambiguous between the two interfaces, zero otherwise.
983 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
984 required to match, which is not the case for ambiguity checks.*/
987 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
988 int generic_flag, int intent_flag,
989 char *errmsg, int err_len)
991 gfc_formal_arglist *f1, *f2;
993 gcc_assert (name2 != NULL);
995 if (s1->attr.function && (s2->attr.subroutine
996 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
997 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1000 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1004 if (s1->attr.subroutine && s2->attr.function)
1007 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1011 /* If the arguments are functions, check type and kind
1012 (only for dummy procedures and procedure pointer assignments). */
1013 if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
1015 if (s1->ts.type == BT_UNKNOWN)
1017 if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
1020 snprintf (errmsg, err_len, "Type/kind mismatch in return value "
1026 if (s1->attr.if_source == IFSRC_UNKNOWN
1027 || s2->attr.if_source == IFSRC_UNKNOWN)
1033 if (f1 == NULL && f2 == NULL)
1034 return 1; /* Special case: No arguments. */
1038 if (count_types_test (f1, f2) || count_types_test (f2, f1))
1040 if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1044 /* Perform the abbreviated correspondence test for operators (the
1045 arguments cannot be optional and are always ordered correctly).
1046 This is also done when comparing interfaces for dummy procedures and in
1047 procedure pointer assignments. */
1051 /* Check existence. */
1052 if (f1 == NULL && f2 == NULL)
1054 if (f1 == NULL || f2 == NULL)
1057 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1058 "arguments", name2);
1062 /* Check type and rank. */
1063 if (!compare_type_rank (f2->sym, f1->sym))
1066 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1072 if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
1074 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1079 /* Check OPTIONAL. */
1080 if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
1082 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1095 /* Given a pointer to an interface pointer, remove duplicate
1096 interfaces and make sure that all symbols are either functions
1097 or subroutines, and all of the same kind. Returns nonzero if
1098 something goes wrong. */
1101 check_interface0 (gfc_interface *p, const char *interface_name)
1103 gfc_interface *psave, *q, *qlast;
1106 for (; p; p = p->next)
1108 /* Make sure all symbols in the interface have been defined as
1109 functions or subroutines. */
1110 if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1111 || !p->sym->attr.if_source)
1113 if (p->sym->attr.external)
1114 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1115 p->sym->name, interface_name, &p->sym->declared_at);
1117 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1118 "subroutine", p->sym->name, interface_name,
1119 &p->sym->declared_at);
1123 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1124 if ((psave->sym->attr.function && !p->sym->attr.function)
1125 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1127 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1128 " or all FUNCTIONs", interface_name, &p->sym->declared_at);
1132 if (p->sym->attr.proc == PROC_INTERNAL
1133 && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' "
1134 "in %s at %L", p->sym->name, interface_name,
1135 &p->sym->declared_at) == FAILURE)
1140 /* Remove duplicate interfaces in this interface list. */
1141 for (; p; p = p->next)
1145 for (q = p->next; q;)
1147 if (p->sym != q->sym)
1154 /* Duplicate interface. */
1155 qlast->next = q->next;
1166 /* Check lists of interfaces to make sure that no two interfaces are
1167 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1170 check_interface1 (gfc_interface *p, gfc_interface *q0,
1171 int generic_flag, const char *interface_name,
1175 for (; p; p = p->next)
1176 for (q = q0; q; q = q->next)
1178 if (p->sym == q->sym)
1179 continue; /* Duplicates OK here. */
1181 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1184 if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
1188 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1189 p->sym->name, q->sym->name, interface_name,
1191 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1192 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1193 p->sym->name, q->sym->name, interface_name,
1196 gfc_warning ("Although not referenced, '%s' has ambiguous "
1197 "interfaces at %L", interface_name, &p->where);
1205 /* Check the generic and operator interfaces of symbols to make sure
1206 that none of the interfaces conflict. The check has to be done
1207 after all of the symbols are actually loaded. */
1210 check_sym_interfaces (gfc_symbol *sym)
1212 char interface_name[100];
1215 if (sym->ns != gfc_current_ns)
1218 if (sym->generic != NULL)
1220 sprintf (interface_name, "generic interface '%s'", sym->name);
1221 if (check_interface0 (sym->generic, interface_name))
1224 for (p = sym->generic; p; p = p->next)
1226 if (p->sym->attr.mod_proc
1227 && (p->sym->attr.if_source != IFSRC_DECL
1228 || p->sym->attr.procedure))
1230 gfc_error ("'%s' at %L is not a module procedure",
1231 p->sym->name, &p->where);
1236 /* Originally, this test was applied to host interfaces too;
1237 this is incorrect since host associated symbols, from any
1238 source, cannot be ambiguous with local symbols. */
1239 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1240 sym->attr.referenced || !sym->attr.use_assoc);
1246 check_uop_interfaces (gfc_user_op *uop)
1248 char interface_name[100];
1252 sprintf (interface_name, "operator interface '%s'", uop->name);
1253 if (check_interface0 (uop->op, interface_name))
1256 for (ns = gfc_current_ns; ns; ns = ns->parent)
1258 uop2 = gfc_find_uop (uop->name, ns);
1262 check_interface1 (uop->op, uop2->op, 0,
1263 interface_name, true);
1267 /* Given an intrinsic op, return an equivalent op if one exists,
1268 or INTRINSIC_NONE otherwise. */
1271 gfc_equivalent_op (gfc_intrinsic_op op)
1276 return INTRINSIC_EQ_OS;
1278 case INTRINSIC_EQ_OS:
1279 return INTRINSIC_EQ;
1282 return INTRINSIC_NE_OS;
1284 case INTRINSIC_NE_OS:
1285 return INTRINSIC_NE;
1288 return INTRINSIC_GT_OS;
1290 case INTRINSIC_GT_OS:
1291 return INTRINSIC_GT;
1294 return INTRINSIC_GE_OS;
1296 case INTRINSIC_GE_OS:
1297 return INTRINSIC_GE;
1300 return INTRINSIC_LT_OS;
1302 case INTRINSIC_LT_OS:
1303 return INTRINSIC_LT;
1306 return INTRINSIC_LE_OS;
1308 case INTRINSIC_LE_OS:
1309 return INTRINSIC_LE;
1312 return INTRINSIC_NONE;
1316 /* For the namespace, check generic, user operator and intrinsic
1317 operator interfaces for consistency and to remove duplicate
1318 interfaces. We traverse the whole namespace, counting on the fact
1319 that most symbols will not have generic or operator interfaces. */
1322 gfc_check_interfaces (gfc_namespace *ns)
1324 gfc_namespace *old_ns, *ns2;
1325 char interface_name[100];
1328 old_ns = gfc_current_ns;
1329 gfc_current_ns = ns;
1331 gfc_traverse_ns (ns, check_sym_interfaces);
1333 gfc_traverse_user_op (ns, check_uop_interfaces);
1335 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1337 if (i == INTRINSIC_USER)
1340 if (i == INTRINSIC_ASSIGN)
1341 strcpy (interface_name, "intrinsic assignment operator");
1343 sprintf (interface_name, "intrinsic '%s' operator",
1344 gfc_op2string ((gfc_intrinsic_op) i));
1346 if (check_interface0 (ns->op[i], interface_name))
1350 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1353 for (ns2 = ns; ns2; ns2 = ns2->parent)
1355 gfc_intrinsic_op other_op;
1357 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1358 interface_name, true))
1361 /* i should be gfc_intrinsic_op, but has to be int with this cast
1362 here for stupid C++ compatibility rules. */
1363 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1364 if (other_op != INTRINSIC_NONE
1365 && check_interface1 (ns->op[i], ns2->op[other_op],
1366 0, interface_name, true))
1372 gfc_current_ns = old_ns;
1377 symbol_rank (gfc_symbol *sym)
1379 return (sym->as == NULL) ? 0 : sym->as->rank;
1383 /* Given a symbol of a formal argument list and an expression, if the
1384 formal argument is allocatable, check that the actual argument is
1385 allocatable. Returns nonzero if compatible, zero if not compatible. */
1388 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1390 symbol_attribute attr;
1392 if (formal->attr.allocatable
1393 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1395 attr = gfc_expr_attr (actual);
1396 if (!attr.allocatable)
1404 /* Given a symbol of a formal argument list and an expression, if the
1405 formal argument is a pointer, see if the actual argument is a
1406 pointer. Returns nonzero if compatible, zero if not compatible. */
1409 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1411 symbol_attribute attr;
1413 if (formal->attr.pointer)
1415 attr = gfc_expr_attr (actual);
1417 /* Fortran 2008 allows non-pointer actual arguments. */
1418 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1429 /* Emit clear error messages for rank mismatch. */
1432 argument_rank_mismatch (const char *name, locus *where,
1433 int rank1, int rank2)
1437 gfc_error ("Rank mismatch in argument '%s' at %L "
1438 "(scalar and rank-%d)", name, where, rank2);
1440 else if (rank2 == 0)
1442 gfc_error ("Rank mismatch in argument '%s' at %L "
1443 "(rank-%d and scalar)", name, where, rank1);
1447 gfc_error ("Rank mismatch in argument '%s' at %L "
1448 "(rank-%d and rank-%d)", name, where, rank1, rank2);
1453 /* Given a symbol of a formal argument list and an expression, see if
1454 the two are compatible as arguments. Returns nonzero if
1455 compatible, zero if not compatible. */
1458 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1459 int ranks_must_agree, int is_elemental, locus *where)
1462 bool rank_check, is_pointer;
1464 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1465 procs c_f_pointer or c_f_procpointer, and we need to accept most
1466 pointers the user could give us. This should allow that. */
1467 if (formal->ts.type == BT_VOID)
1470 if (formal->ts.type == BT_DERIVED
1471 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1472 && actual->ts.type == BT_DERIVED
1473 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1476 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1477 /* Make sure the vtab symbol is present when
1478 the module variables are generated. */
1479 gfc_find_derived_vtab (actual->ts.u.derived);
1481 if (actual->ts.type == BT_PROCEDURE)
1484 gfc_symbol *act_sym = actual->symtree->n.sym;
1486 if (formal->attr.flavor != FL_PROCEDURE)
1489 gfc_error ("Invalid procedure argument at %L", &actual->where);
1493 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1497 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1498 formal->name, &actual->where, err);
1502 if (formal->attr.function && !act_sym->attr.function)
1504 gfc_add_function (&act_sym->attr, act_sym->name,
1505 &act_sym->declared_at);
1506 if (act_sym->ts.type == BT_UNKNOWN
1507 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1510 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1511 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1512 &act_sym->declared_at);
1518 if (formal->attr.pointer && formal->attr.contiguous
1519 && !gfc_is_simply_contiguous (actual, true))
1522 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1523 "must be simply contigous", formal->name, &actual->where);
1527 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1528 && actual->ts.type != BT_HOLLERITH
1529 && !gfc_compare_types (&formal->ts, &actual->ts))
1532 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1533 formal->name, &actual->where, gfc_typename (&actual->ts),
1534 gfc_typename (&formal->ts));
1538 /* F2003, 12.5.2.5. */
1539 if (formal->ts.type == BT_CLASS
1540 && (CLASS_DATA (formal)->attr.class_pointer
1541 || CLASS_DATA (formal)->attr.allocatable))
1543 if (actual->ts.type != BT_CLASS)
1546 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1547 formal->name, &actual->where);
1550 if (CLASS_DATA (actual)->ts.u.derived
1551 != CLASS_DATA (formal)->ts.u.derived)
1554 gfc_error ("Actual argument to '%s' at %L must have the same "
1555 "declared type", formal->name, &actual->where);
1560 if (formal->attr.codimension && !gfc_is_coarray (actual))
1563 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1564 formal->name, &actual->where);
1568 if (formal->attr.codimension && formal->attr.allocatable)
1570 gfc_ref *last = NULL;
1572 for (ref = actual->ref; ref; ref = ref->next)
1573 if (ref->type == REF_COMPONENT)
1576 /* F2008, 12.5.2.6. */
1577 if ((last && last->u.c.component->as->corank != formal->as->corank)
1579 && actual->symtree->n.sym->as->corank != formal->as->corank))
1582 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1583 formal->name, &actual->where, formal->as->corank,
1584 last ? last->u.c.component->as->corank
1585 : actual->symtree->n.sym->as->corank);
1590 if (formal->attr.codimension)
1592 /* F2008, 12.5.2.8. */
1593 if (formal->attr.dimension
1594 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1595 && gfc_expr_attr (actual).dimension
1596 && !gfc_is_simply_contiguous (actual, true))
1599 gfc_error ("Actual argument to '%s' at %L must be simply "
1600 "contiguous", formal->name, &actual->where);
1604 /* F2008, C1303 and C1304. */
1605 if (formal->attr.intent != INTENT_INOUT
1606 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1607 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1608 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1609 || formal->attr.lock_comp))
1613 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1614 "which is LOCK_TYPE or has a LOCK_TYPE component",
1615 formal->name, &actual->where);
1620 /* F2008, C1239/C1240. */
1621 if (actual->expr_type == EXPR_VARIABLE
1622 && (actual->symtree->n.sym->attr.asynchronous
1623 || actual->symtree->n.sym->attr.volatile_)
1624 && (formal->attr.asynchronous || formal->attr.volatile_)
1625 && actual->rank && !gfc_is_simply_contiguous (actual, true)
1626 && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1627 || formal->attr.contiguous))
1630 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1631 "array without CONTIGUOUS attribute - as actual argument at"
1632 " %L is not simply contiguous and both are ASYNCHRONOUS "
1633 "or VOLATILE", formal->name, &actual->where);
1637 if (formal->attr.allocatable && !formal->attr.codimension
1638 && gfc_expr_attr (actual).codimension)
1640 if (formal->attr.intent == INTENT_OUT)
1643 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1644 "INTENT(OUT) dummy argument '%s'", &actual->where,
1648 else if (gfc_option.warn_surprising && where
1649 && formal->attr.intent != INTENT_IN)
1650 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1651 "argument '%s', which is invalid if the allocation status"
1652 " is modified", &actual->where, formal->name);
1655 if (symbol_rank (formal) == actual->rank)
1658 rank_check = where != NULL && !is_elemental && formal->as
1659 && (formal->as->type == AS_ASSUMED_SHAPE
1660 || formal->as->type == AS_DEFERRED)
1661 && actual->expr_type != EXPR_NULL;
1663 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1664 if (rank_check || ranks_must_agree
1665 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1666 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1667 || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
1668 && actual->expr_type != EXPR_NULL)
1669 || (actual->rank == 0 && formal->attr.dimension
1670 && gfc_is_coindexed (actual)))
1673 argument_rank_mismatch (formal->name, &actual->where,
1674 symbol_rank (formal), actual->rank);
1677 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1680 /* At this point, we are considering a scalar passed to an array. This
1681 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1682 - if the actual argument is (a substring of) an element of a
1683 non-assumed-shape/non-pointer/non-polymorphic array; or
1684 - (F2003) if the actual argument is of type character of default/c_char
1687 is_pointer = actual->expr_type == EXPR_VARIABLE
1688 ? actual->symtree->n.sym->attr.pointer : false;
1690 for (ref = actual->ref; ref; ref = ref->next)
1692 if (ref->type == REF_COMPONENT)
1693 is_pointer = ref->u.c.component->attr.pointer;
1694 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1695 && ref->u.ar.dimen > 0
1697 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
1701 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
1704 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1705 "at %L", formal->name, &actual->where);
1709 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
1710 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1713 gfc_error ("Element of assumed-shaped or pointer "
1714 "array passed to array dummy argument '%s' at %L",
1715 formal->name, &actual->where);
1719 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
1720 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1722 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
1725 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1726 "CHARACTER actual argument with array dummy argument "
1727 "'%s' at %L", formal->name, &actual->where);
1731 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1733 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1734 "array dummy argument '%s' at %L",
1735 formal->name, &actual->where);
1738 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1744 if (ref == NULL && actual->expr_type != EXPR_NULL)
1747 argument_rank_mismatch (formal->name, &actual->where,
1748 symbol_rank (formal), actual->rank);
1756 /* Returns the storage size of a symbol (formal argument) or
1757 zero if it cannot be determined. */
1759 static unsigned long
1760 get_sym_storage_size (gfc_symbol *sym)
1763 unsigned long strlen, elements;
1765 if (sym->ts.type == BT_CHARACTER)
1767 if (sym->ts.u.cl && sym->ts.u.cl->length
1768 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1769 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1776 if (symbol_rank (sym) == 0)
1780 if (sym->as->type != AS_EXPLICIT)
1782 for (i = 0; i < sym->as->rank; i++)
1784 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1785 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1788 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
1789 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
1792 return strlen*elements;
1796 /* Returns the storage size of an expression (actual argument) or
1797 zero if it cannot be determined. For an array element, it returns
1798 the remaining size as the element sequence consists of all storage
1799 units of the actual argument up to the end of the array. */
1801 static unsigned long
1802 get_expr_storage_size (gfc_expr *e)
1805 long int strlen, elements;
1806 long int substrlen = 0;
1807 bool is_str_storage = false;
1813 if (e->ts.type == BT_CHARACTER)
1815 if (e->ts.u.cl && e->ts.u.cl->length
1816 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1817 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1818 else if (e->expr_type == EXPR_CONSTANT
1819 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1820 strlen = e->value.character.length;
1825 strlen = 1; /* Length per element. */
1827 if (e->rank == 0 && !e->ref)
1835 for (i = 0; i < e->rank; i++)
1836 elements *= mpz_get_si (e->shape[i]);
1837 return elements*strlen;
1840 for (ref = e->ref; ref; ref = ref->next)
1842 if (ref->type == REF_SUBSTRING && ref->u.ss.start
1843 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1847 /* The string length is the substring length.
1848 Set now to full string length. */
1849 if (ref->u.ss.length == NULL
1850 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1853 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1855 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1859 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1860 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1861 && ref->u.ar.as->upper)
1862 for (i = 0; i < ref->u.ar.dimen; i++)
1864 long int start, end, stride;
1867 if (ref->u.ar.stride[i])
1869 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1870 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1875 if (ref->u.ar.start[i])
1877 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1878 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1882 else if (ref->u.ar.as->lower[i]
1883 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1884 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1888 if (ref->u.ar.end[i])
1890 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1891 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1895 else if (ref->u.ar.as->upper[i]
1896 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1897 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1901 elements *= (end - start)/stride + 1L;
1903 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1904 && ref->u.ar.as->lower && ref->u.ar.as->upper)
1905 for (i = 0; i < ref->u.ar.as->rank; i++)
1907 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1908 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1909 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1910 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1911 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1916 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1917 && e->expr_type == EXPR_VARIABLE)
1919 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
1920 || e->symtree->n.sym->attr.pointer)
1926 /* Determine the number of remaining elements in the element
1927 sequence for array element designators. */
1928 is_str_storage = true;
1929 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1931 if (ref->u.ar.start[i] == NULL
1932 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1933 || ref->u.ar.as->upper[i] == NULL
1934 || ref->u.ar.as->lower[i] == NULL
1935 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1936 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1941 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1942 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1944 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1945 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1951 return (is_str_storage) ? substrlen + (elements-1)*strlen
1954 return elements*strlen;
1958 /* Given an expression, check whether it is an array section
1959 which has a vector subscript. If it has, one is returned,
1963 gfc_has_vector_subscript (gfc_expr *e)
1968 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1971 for (ref = e->ref; ref; ref = ref->next)
1972 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1973 for (i = 0; i < ref->u.ar.dimen; i++)
1974 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1981 /* Given formal and actual argument lists, see if they are compatible.
1982 If they are compatible, the actual argument list is sorted to
1983 correspond with the formal list, and elements for missing optional
1984 arguments are inserted. If WHERE pointer is nonnull, then we issue
1985 errors when things don't match instead of just returning the status
1989 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1990 int ranks_must_agree, int is_elemental, locus *where)
1992 gfc_actual_arglist **new_arg, *a, *actual, temp;
1993 gfc_formal_arglist *f;
1995 unsigned long actual_size, formal_size;
1999 if (actual == NULL && formal == NULL)
2003 for (f = formal; f; f = f->next)
2006 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2008 for (i = 0; i < n; i++)
2015 for (a = actual; a; a = a->next, f = f->next)
2017 /* Look for keywords but ignore g77 extensions like %VAL. */
2018 if (a->name != NULL && a->name[0] != '%')
2021 for (f = formal; f; f = f->next, i++)
2025 if (strcmp (f->sym->name, a->name) == 0)
2032 gfc_error ("Keyword argument '%s' at %L is not in "
2033 "the procedure", a->name, &a->expr->where);
2037 if (new_arg[i] != NULL)
2040 gfc_error ("Keyword argument '%s' at %L is already associated "
2041 "with another actual argument", a->name,
2050 gfc_error ("More actual than formal arguments in procedure "
2051 "call at %L", where);
2056 if (f->sym == NULL && a->expr == NULL)
2062 gfc_error ("Missing alternate return spec in subroutine call "
2067 if (a->expr == NULL)
2070 gfc_error ("Unexpected alternate return spec in subroutine "
2071 "call at %L", where);
2075 if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
2076 && (f->sym->attr.allocatable || !f->sym->attr.optional
2077 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2079 if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
2080 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2081 where, f->sym->name);
2083 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2084 "dummy '%s'", where, f->sym->name);
2089 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2090 is_elemental, where))
2093 /* Special case for character arguments. For allocatable, pointer
2094 and assumed-shape dummies, the string length needs to match
2096 if (a->expr->ts.type == BT_CHARACTER
2097 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2098 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2099 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2100 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2101 && (f->sym->attr.pointer || f->sym->attr.allocatable
2102 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2103 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2104 f->sym->ts.u.cl->length->value.integer) != 0))
2106 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2107 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2108 "argument and pointer or allocatable dummy argument "
2110 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2111 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2112 f->sym->name, &a->expr->where);
2114 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2115 "argument and assumed-shape dummy argument '%s' "
2117 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2118 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2119 f->sym->name, &a->expr->where);
2123 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2124 && f->sym->ts.deferred != a->expr->ts.deferred
2125 && a->expr->ts.type == BT_CHARACTER)
2128 gfc_error ("Actual argument argument at %L to allocatable or "
2129 "pointer dummy argument '%s' must have a deferred "
2130 "length type parameter if and only if the dummy has one",
2131 &a->expr->where, f->sym->name);
2135 actual_size = get_expr_storage_size (a->expr);
2136 formal_size = get_sym_storage_size (f->sym);
2137 if (actual_size != 0 && actual_size < formal_size
2138 && a->expr->ts.type != BT_PROCEDURE
2139 && f->sym->attr.flavor != FL_PROCEDURE)
2141 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2142 gfc_warning ("Character length of actual argument shorter "
2143 "than of dummy argument '%s' (%lu/%lu) at %L",
2144 f->sym->name, actual_size, formal_size,
2147 gfc_warning ("Actual argument contains too few "
2148 "elements for dummy argument '%s' (%lu/%lu) at %L",
2149 f->sym->name, actual_size, formal_size,
2154 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2155 is provided for a procedure pointer formal argument. */
2156 if (f->sym->attr.proc_pointer
2157 && !((a->expr->expr_type == EXPR_VARIABLE
2158 && a->expr->symtree->n.sym->attr.proc_pointer)
2159 || (a->expr->expr_type == EXPR_FUNCTION
2160 && a->expr->symtree->n.sym->result->attr.proc_pointer)
2161 || gfc_is_proc_ptr_comp (a->expr, NULL)))
2164 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2165 f->sym->name, &a->expr->where);
2169 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2170 provided for a procedure formal argument. */
2171 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2172 && a->expr->expr_type == EXPR_VARIABLE
2173 && f->sym->attr.flavor == FL_PROCEDURE)
2176 gfc_error ("Expected a procedure for argument '%s' at %L",
2177 f->sym->name, &a->expr->where);
2181 if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
2182 && a->expr->ts.type == BT_PROCEDURE
2183 && !a->expr->symtree->n.sym->attr.pure)
2186 gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2187 f->sym->name, &a->expr->where);
2191 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2192 && a->expr->expr_type == EXPR_VARIABLE
2193 && a->expr->symtree->n.sym->as
2194 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2195 && (a->expr->ref == NULL
2196 || (a->expr->ref->type == REF_ARRAY
2197 && a->expr->ref->u.ar.type == AR_FULL)))
2200 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2201 " array at %L", f->sym->name, where);
2205 if (a->expr->expr_type != EXPR_NULL
2206 && compare_pointer (f->sym, a->expr) == 0)
2209 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2210 f->sym->name, &a->expr->where);
2214 if (a->expr->expr_type != EXPR_NULL
2215 && (gfc_option.allow_std & GFC_STD_F2008) == 0
2216 && compare_pointer (f->sym, a->expr) == 2)
2219 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2220 "pointer dummy '%s'", &a->expr->where,f->sym->name);
2225 /* Fortran 2008, C1242. */
2226 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2229 gfc_error ("Coindexed actual argument at %L to pointer "
2231 &a->expr->where, f->sym->name);
2235 /* Fortran 2008, 12.5.2.5 (no constraint). */
2236 if (a->expr->expr_type == EXPR_VARIABLE
2237 && f->sym->attr.intent != INTENT_IN
2238 && f->sym->attr.allocatable
2239 && gfc_is_coindexed (a->expr))
2242 gfc_error ("Coindexed actual argument at %L to allocatable "
2243 "dummy '%s' requires INTENT(IN)",
2244 &a->expr->where, f->sym->name);
2248 /* Fortran 2008, C1237. */
2249 if (a->expr->expr_type == EXPR_VARIABLE
2250 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2251 && gfc_is_coindexed (a->expr)
2252 && (a->expr->symtree->n.sym->attr.volatile_
2253 || a->expr->symtree->n.sym->attr.asynchronous))
2256 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2257 "at %L requires that dummy %s' has neither "
2258 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2263 /* Fortran 2008, 12.5.2.4 (no constraint). */
2264 if (a->expr->expr_type == EXPR_VARIABLE
2265 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2266 && gfc_is_coindexed (a->expr)
2267 && gfc_has_ultimate_allocatable (a->expr))
2270 gfc_error ("Coindexed actual argument at %L with allocatable "
2271 "ultimate component to dummy '%s' requires either VALUE "
2272 "or INTENT(IN)", &a->expr->where, f->sym->name);
2276 if (a->expr->expr_type != EXPR_NULL
2277 && compare_allocatable (f->sym, a->expr) == 0)
2280 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2281 f->sym->name, &a->expr->where);
2285 /* Check intent = OUT/INOUT for definable actual argument. */
2286 if ((f->sym->attr.intent == INTENT_OUT
2287 || f->sym->attr.intent == INTENT_INOUT))
2289 const char* context = (where
2290 ? _("actual argument to INTENT = OUT/INOUT")
2293 if (f->sym->attr.pointer
2294 && gfc_check_vardef_context (a->expr, true, false, context)
2297 if (gfc_check_vardef_context (a->expr, false, false, context)
2302 if ((f->sym->attr.intent == INTENT_OUT
2303 || f->sym->attr.intent == INTENT_INOUT
2304 || f->sym->attr.volatile_
2305 || f->sym->attr.asynchronous)
2306 && gfc_has_vector_subscript (a->expr))
2309 gfc_error ("Array-section actual argument with vector "
2310 "subscripts at %L is incompatible with INTENT(OUT), "
2311 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2312 "of the dummy argument '%s'",
2313 &a->expr->where, f->sym->name);
2317 /* C1232 (R1221) For an actual argument which is an array section or
2318 an assumed-shape array, the dummy argument shall be an assumed-
2319 shape array, if the dummy argument has the VOLATILE attribute. */
2321 if (f->sym->attr.volatile_
2322 && a->expr->symtree->n.sym->as
2323 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2324 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2327 gfc_error ("Assumed-shape actual argument at %L is "
2328 "incompatible with the non-assumed-shape "
2329 "dummy argument '%s' due to VOLATILE attribute",
2330 &a->expr->where,f->sym->name);
2334 if (f->sym->attr.volatile_
2335 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2336 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2339 gfc_error ("Array-section actual argument at %L is "
2340 "incompatible with the non-assumed-shape "
2341 "dummy argument '%s' due to VOLATILE attribute",
2342 &a->expr->where,f->sym->name);
2346 /* C1233 (R1221) For an actual argument which is a pointer array, the
2347 dummy argument shall be an assumed-shape or pointer array, if the
2348 dummy argument has the VOLATILE attribute. */
2350 if (f->sym->attr.volatile_
2351 && a->expr->symtree->n.sym->attr.pointer
2352 && a->expr->symtree->n.sym->as
2354 && (f->sym->as->type == AS_ASSUMED_SHAPE
2355 || f->sym->attr.pointer)))
2358 gfc_error ("Pointer-array actual argument at %L requires "
2359 "an assumed-shape or pointer-array dummy "
2360 "argument '%s' due to VOLATILE attribute",
2361 &a->expr->where,f->sym->name);
2372 /* Make sure missing actual arguments are optional. */
2374 for (f = formal; f; f = f->next, i++)
2376 if (new_arg[i] != NULL)
2381 gfc_error ("Missing alternate return spec in subroutine call "
2385 if (!f->sym->attr.optional)
2388 gfc_error ("Missing actual argument for argument '%s' at %L",
2389 f->sym->name, where);
2394 /* The argument lists are compatible. We now relink a new actual
2395 argument list with null arguments in the right places. The head
2396 of the list remains the head. */
2397 for (i = 0; i < n; i++)
2398 if (new_arg[i] == NULL)
2399 new_arg[i] = gfc_get_actual_arglist ();
2404 *new_arg[0] = *actual;
2408 new_arg[0] = new_arg[na];
2412 for (i = 0; i < n - 1; i++)
2413 new_arg[i]->next = new_arg[i + 1];
2415 new_arg[i]->next = NULL;
2417 if (*ap == NULL && n > 0)
2420 /* Note the types of omitted optional arguments. */
2421 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2422 if (a->expr == NULL && a->label == NULL)
2423 a->missing_arg_type = f->sym->ts.type;
2431 gfc_formal_arglist *f;
2432 gfc_actual_arglist *a;
2436 /* qsort comparison function for argument pairs, with the following
2438 - p->a->expr == NULL
2439 - p->a->expr->expr_type != EXPR_VARIABLE
2440 - growing p->a->expr->symbol. */
2443 pair_cmp (const void *p1, const void *p2)
2445 const gfc_actual_arglist *a1, *a2;
2447 /* *p1 and *p2 are elements of the to-be-sorted array. */
2448 a1 = ((const argpair *) p1)->a;
2449 a2 = ((const argpair *) p2)->a;
2458 if (a1->expr->expr_type != EXPR_VARIABLE)
2460 if (a2->expr->expr_type != EXPR_VARIABLE)
2464 if (a2->expr->expr_type != EXPR_VARIABLE)
2466 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2470 /* Given two expressions from some actual arguments, test whether they
2471 refer to the same expression. The analysis is conservative.
2472 Returning FAILURE will produce no warning. */
2475 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2477 const gfc_ref *r1, *r2;
2480 || e1->expr_type != EXPR_VARIABLE
2481 || e2->expr_type != EXPR_VARIABLE
2482 || e1->symtree->n.sym != e2->symtree->n.sym)
2485 /* TODO: improve comparison, see expr.c:show_ref(). */
2486 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2488 if (r1->type != r2->type)
2493 if (r1->u.ar.type != r2->u.ar.type)
2495 /* TODO: At the moment, consider only full arrays;
2496 we could do better. */
2497 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2502 if (r1->u.c.component != r2->u.c.component)
2510 gfc_internal_error ("compare_actual_expr(): Bad component code");
2519 /* Given formal and actual argument lists that correspond to one
2520 another, check that identical actual arguments aren't not
2521 associated with some incompatible INTENTs. */
2524 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2526 sym_intent f1_intent, f2_intent;
2527 gfc_formal_arglist *f1;
2528 gfc_actual_arglist *a1;
2531 gfc_try t = SUCCESS;
2534 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2536 if (f1 == NULL && a1 == NULL)
2538 if (f1 == NULL || a1 == NULL)
2539 gfc_internal_error ("check_some_aliasing(): List mismatch");
2544 p = XALLOCAVEC (argpair, n);
2546 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2552 qsort (p, n, sizeof (argpair), pair_cmp);
2554 for (i = 0; i < n; i++)
2557 || p[i].a->expr->expr_type != EXPR_VARIABLE
2558 || p[i].a->expr->ts.type == BT_PROCEDURE)
2560 f1_intent = p[i].f->sym->attr.intent;
2561 for (j = i + 1; j < n; j++)
2563 /* Expected order after the sort. */
2564 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2565 gfc_internal_error ("check_some_aliasing(): corrupted data");
2567 /* Are the expression the same? */
2568 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2570 f2_intent = p[j].f->sym->attr.intent;
2571 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2572 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2574 gfc_warning ("Same actual argument associated with INTENT(%s) "
2575 "argument '%s' and INTENT(%s) argument '%s' at %L",
2576 gfc_intent_string (f1_intent), p[i].f->sym->name,
2577 gfc_intent_string (f2_intent), p[j].f->sym->name,
2578 &p[i].a->expr->where);
2588 /* Given a symbol of a formal argument list and an expression,
2589 return nonzero if their intents are compatible, zero otherwise. */
2592 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2594 if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2597 if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2600 if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2607 /* Given formal and actual argument lists that correspond to one
2608 another, check that they are compatible in the sense that intents
2609 are not mismatched. */
2612 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2614 sym_intent f_intent;
2616 for (;; f = f->next, a = a->next)
2618 if (f == NULL && a == NULL)
2620 if (f == NULL || a == NULL)
2621 gfc_internal_error ("check_intents(): List mismatch");
2623 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2626 f_intent = f->sym->attr.intent;
2628 if (!compare_parameter_intent(f->sym, a->expr))
2630 gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2631 "specifies INTENT(%s)", &a->expr->where,
2632 gfc_intent_string (f_intent));
2636 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2638 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2640 gfc_error ("Procedure argument at %L is local to a PURE "
2641 "procedure and is passed to an INTENT(%s) argument",
2642 &a->expr->where, gfc_intent_string (f_intent));
2646 if (f->sym->attr.pointer)
2648 gfc_error ("Procedure argument at %L is local to a PURE "
2649 "procedure and has the POINTER attribute",
2655 /* Fortran 2008, C1283. */
2656 if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2658 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2660 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2661 "is passed to an INTENT(%s) argument",
2662 &a->expr->where, gfc_intent_string (f_intent));
2666 if (f->sym->attr.pointer)
2668 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2669 "is passed to a POINTER dummy argument",
2675 /* F2008, Section 12.5.2.4. */
2676 if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2677 && gfc_is_coindexed (a->expr))
2679 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2680 "polymorphic dummy argument '%s'",
2681 &a->expr->where, f->sym->name);
2690 /* Check how a procedure is used against its interface. If all goes
2691 well, the actual argument list will also end up being properly
2695 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2698 /* Warn about calls with an implicit interface. Special case
2699 for calling a ISO_C_BINDING becase c_loc and c_funloc
2700 are pseudo-unknown. Additionally, warn about procedures not
2701 explicitly declared at all if requested. */
2702 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2704 if (gfc_option.warn_implicit_interface)
2705 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2707 else if (gfc_option.warn_implicit_procedure
2708 && sym->attr.proc == PROC_UNKNOWN)
2709 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2713 if (sym->attr.if_source == IFSRC_UNKNOWN)
2715 gfc_actual_arglist *a;
2717 if (sym->attr.pointer)
2719 gfc_error("The pointer object '%s' at %L must have an explicit "
2720 "function interface or be declared as array",
2725 if (sym->attr.allocatable && !sym->attr.external)
2727 gfc_error("The allocatable object '%s' at %L must have an explicit "
2728 "function interface or be declared as array",
2733 if (sym->attr.allocatable)
2735 gfc_error("Allocatable function '%s' at %L must have an explicit "
2736 "function interface", sym->name, where);
2740 for (a = *ap; a; a = a->next)
2742 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2743 if (a->name != NULL && a->name[0] != '%')
2745 gfc_error("Keyword argument requires explicit interface "
2746 "for procedure '%s' at %L", sym->name, &a->expr->where);
2750 /* F2008, C1303 and C1304. */
2752 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
2753 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2754 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2755 || gfc_expr_attr (a->expr).lock_comp))
2757 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
2758 "component at %L requires an explicit interface for "
2759 "procedure '%s'", &a->expr->where, sym->name);
2767 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2770 check_intents (sym->formal, *ap);
2771 if (gfc_option.warn_aliasing)
2772 check_some_aliasing (sym->formal, *ap);
2776 /* Check how a procedure pointer component is used against its interface.
2777 If all goes well, the actual argument list will also end up being properly
2778 sorted. Completely analogous to gfc_procedure_use. */
2781 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2784 /* Warn about calls with an implicit interface. Special case
2785 for calling a ISO_C_BINDING becase c_loc and c_funloc
2786 are pseudo-unknown. */
2787 if (gfc_option.warn_implicit_interface
2788 && comp->attr.if_source == IFSRC_UNKNOWN
2789 && !comp->attr.is_iso_c)
2790 gfc_warning ("Procedure pointer component '%s' called with an implicit "
2791 "interface at %L", comp->name, where);
2793 if (comp->attr.if_source == IFSRC_UNKNOWN)
2795 gfc_actual_arglist *a;
2796 for (a = *ap; a; a = a->next)
2798 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2799 if (a->name != NULL && a->name[0] != '%')
2801 gfc_error("Keyword argument requires explicit interface "
2802 "for procedure pointer component '%s' at %L",
2803 comp->name, &a->expr->where);
2811 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2814 check_intents (comp->formal, *ap);
2815 if (gfc_option.warn_aliasing)
2816 check_some_aliasing (comp->formal, *ap);
2820 /* Try if an actual argument list matches the formal list of a symbol,
2821 respecting the symbol's attributes like ELEMENTAL. This is used for
2822 GENERIC resolution. */
2825 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2829 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2831 r = !sym->attr.elemental;
2832 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2834 check_intents (sym->formal, *args);
2835 if (gfc_option.warn_aliasing)
2836 check_some_aliasing (sym->formal, *args);
2844 /* Given an interface pointer and an actual argument list, search for
2845 a formal argument list that matches the actual. If found, returns
2846 a pointer to the symbol of the correct interface. Returns NULL if
2850 gfc_search_interface (gfc_interface *intr, int sub_flag,
2851 gfc_actual_arglist **ap)
2853 gfc_symbol *elem_sym = NULL;
2854 for (; intr; intr = intr->next)
2856 if (sub_flag && intr->sym->attr.function)
2858 if (!sub_flag && intr->sym->attr.subroutine)
2861 if (gfc_arglist_matches_symbol (ap, intr->sym))
2863 /* Satisfy 12.4.4.1 such that an elemental match has lower
2864 weight than a non-elemental match. */
2865 if (intr->sym->attr.elemental)
2867 elem_sym = intr->sym;
2874 return elem_sym ? elem_sym : NULL;
2878 /* Do a brute force recursive search for a symbol. */
2880 static gfc_symtree *
2881 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2885 if (root->n.sym == sym)
2890 st = find_symtree0 (root->left, sym);
2891 if (root->right && ! st)
2892 st = find_symtree0 (root->right, sym);
2897 /* Find a symtree for a symbol. */
2900 gfc_find_sym_in_symtree (gfc_symbol *sym)
2905 /* First try to find it by name. */
2906 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2907 if (st && st->n.sym == sym)
2910 /* If it's been renamed, resort to a brute-force search. */
2911 /* TODO: avoid having to do this search. If the symbol doesn't exist
2912 in the symtree for the current namespace, it should probably be added. */
2913 for (ns = gfc_current_ns; ns; ns = ns->parent)
2915 st = find_symtree0 (ns->sym_root, sym);
2919 gfc_internal_error ("Unable to find symbol %s", sym->name);
2924 /* See if the arglist to an operator-call contains a derived-type argument
2925 with a matching type-bound operator. If so, return the matching specific
2926 procedure defined as operator-target as well as the base-object to use
2927 (which is the found derived-type argument with operator). The generic
2928 name, if any, is transmitted to the final expression via 'gname'. */
2930 static gfc_typebound_proc*
2931 matching_typebound_op (gfc_expr** tb_base,
2932 gfc_actual_arglist* args,
2933 gfc_intrinsic_op op, const char* uop,
2934 const char ** gname)
2936 gfc_actual_arglist* base;
2938 for (base = args; base; base = base->next)
2939 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
2941 gfc_typebound_proc* tb;
2942 gfc_symbol* derived;
2945 if (base->expr->ts.type == BT_CLASS)
2947 if (!gfc_expr_attr (base->expr).class_ok)
2949 derived = CLASS_DATA (base->expr)->ts.u.derived;
2952 derived = base->expr->ts.u.derived;
2954 if (op == INTRINSIC_USER)
2956 gfc_symtree* tb_uop;
2959 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2968 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2971 /* This means we hit a PRIVATE operator which is use-associated and
2972 should thus not be seen. */
2973 if (result == FAILURE)
2976 /* Look through the super-type hierarchy for a matching specific
2978 for (; tb; tb = tb->overridden)
2982 gcc_assert (tb->is_generic);
2983 for (g = tb->u.generic; g; g = g->next)
2986 gfc_actual_arglist* argcopy;
2989 gcc_assert (g->specific);
2990 if (g->specific->error)
2993 target = g->specific->u.specific->n.sym;
2995 /* Check if this arglist matches the formal. */
2996 argcopy = gfc_copy_actual_arglist (args);
2997 matches = gfc_arglist_matches_symbol (&argcopy, target);
2998 gfc_free_actual_arglist (argcopy);
3000 /* Return if we found a match. */
3003 *tb_base = base->expr;
3004 *gname = g->specific_st->name;
3015 /* For the 'actual arglist' of an operator call and a specific typebound
3016 procedure that has been found the target of a type-bound operator, build the
3017 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3018 type-bound procedures rather than resolving type-bound operators 'directly'
3019 so that we can reuse the existing logic. */
3022 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3023 gfc_expr* base, gfc_typebound_proc* target,
3026 e->expr_type = EXPR_COMPCALL;
3027 e->value.compcall.tbp = target;
3028 e->value.compcall.name = gname ? gname : "$op";
3029 e->value.compcall.actual = actual;
3030 e->value.compcall.base_object = base;
3031 e->value.compcall.ignore_pass = 1;
3032 e->value.compcall.assign = 0;
3036 /* This subroutine is called when an expression is being resolved.
3037 The expression node in question is either a user defined operator
3038 or an intrinsic operator with arguments that aren't compatible
3039 with the operator. This subroutine builds an actual argument list
3040 corresponding to the operands, then searches for a compatible
3041 interface. If one is found, the expression node is replaced with
3042 the appropriate function call.
3043 real_error is an additional output argument that specifies if FAILURE
3044 is because of some real error and not because no match was found. */
3047 gfc_extend_expr (gfc_expr *e, bool *real_error)
3049 gfc_actual_arglist *actual;
3058 actual = gfc_get_actual_arglist ();
3059 actual->expr = e->value.op.op1;
3061 *real_error = false;
3064 if (e->value.op.op2 != NULL)
3066 actual->next = gfc_get_actual_arglist ();
3067 actual->next->expr = e->value.op.op2;
3070 i = fold_unary_intrinsic (e->value.op.op);
3072 if (i == INTRINSIC_USER)
3074 for (ns = gfc_current_ns; ns; ns = ns->parent)
3076 uop = gfc_find_uop (e->value.op.uop->name, ns);
3080 sym = gfc_search_interface (uop->op, 0, &actual);
3087 for (ns = gfc_current_ns; ns; ns = ns->parent)
3089 /* Due to the distinction between '==' and '.eq.' and friends, one has
3090 to check if either is defined. */
3093 #define CHECK_OS_COMPARISON(comp) \
3094 case INTRINSIC_##comp: \
3095 case INTRINSIC_##comp##_OS: \
3096 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3098 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3100 CHECK_OS_COMPARISON(EQ)
3101 CHECK_OS_COMPARISON(NE)
3102 CHECK_OS_COMPARISON(GT)
3103 CHECK_OS_COMPARISON(GE)
3104 CHECK_OS_COMPARISON(LT)
3105 CHECK_OS_COMPARISON(LE)
3106 #undef CHECK_OS_COMPARISON
3109 sym = gfc_search_interface (ns->op[i], 0, &actual);
3117 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3118 found rather than just taking the first one and not checking further. */
3122 gfc_typebound_proc* tbo;
3125 /* See if we find a matching type-bound operator. */
3126 if (i == INTRINSIC_USER)
3127 tbo = matching_typebound_op (&tb_base, actual,
3128 i, e->value.op.uop->name, &gname);
3132 #define CHECK_OS_COMPARISON(comp) \
3133 case INTRINSIC_##comp: \
3134 case INTRINSIC_##comp##_OS: \
3135 tbo = matching_typebound_op (&tb_base, actual, \
3136 INTRINSIC_##comp, NULL, &gname); \
3138 tbo = matching_typebound_op (&tb_base, actual, \
3139 INTRINSIC_##comp##_OS, NULL, &gname); \
3141 CHECK_OS_COMPARISON(EQ)
3142 CHECK_OS_COMPARISON(NE)
3143 CHECK_OS_COMPARISON(GT)
3144 CHECK_OS_COMPARISON(GE)
3145 CHECK_OS_COMPARISON(LT)
3146 CHECK_OS_COMPARISON(LE)
3147 #undef CHECK_OS_COMPARISON
3150 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3154 /* If there is a matching typebound-operator, replace the expression with
3155 a call to it and succeed. */
3160 gcc_assert (tb_base);
3161 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3163 result = gfc_resolve_expr (e);
3164 if (result == FAILURE)
3170 /* Don't use gfc_free_actual_arglist(). */
3171 free (actual->next);
3177 /* Change the expression node to a function call. */
3178 e->expr_type = EXPR_FUNCTION;
3179 e->symtree = gfc_find_sym_in_symtree (sym);
3180 e->value.function.actual = actual;
3181 e->value.function.esym = NULL;
3182 e->value.function.isym = NULL;
3183 e->value.function.name = NULL;
3184 e->user_operator = 1;
3186 if (gfc_resolve_expr (e) == FAILURE)
3196 /* Tries to replace an assignment code node with a subroutine call to
3197 the subroutine associated with the assignment operator. Return
3198 SUCCESS if the node was replaced. On FAILURE, no error is
3202 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3204 gfc_actual_arglist *actual;
3205 gfc_expr *lhs, *rhs;
3214 /* Don't allow an intrinsic assignment to be replaced. */
3215 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3216 && (rhs->rank == 0 || rhs->rank == lhs->rank)
3217 && (lhs->ts.type == rhs->ts.type
3218 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3221 actual = gfc_get_actual_arglist ();
3224 actual->next = gfc_get_actual_arglist ();
3225 actual->next->expr = rhs;
3229 for (; ns; ns = ns->parent)
3231 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3236 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3240 gfc_typebound_proc* tbo;
3243 /* See if we find a matching type-bound assignment. */
3244 tbo = matching_typebound_op (&tb_base, actual,
3245 INTRINSIC_ASSIGN, NULL, &gname);
3247 /* If there is one, replace the expression with a call to it and
3251 gcc_assert (tb_base);
3252 c->expr1 = gfc_get_expr ();
3253 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3254 c->expr1->value.compcall.assign = 1;
3255 c->expr1->where = c->loc;
3257 c->op = EXEC_COMPCALL;
3259 /* c is resolved from the caller, so no need to do it here. */
3264 free (actual->next);
3269 /* Replace the assignment with the call. */
3270 c->op = EXEC_ASSIGN_CALL;
3271 c->symtree = gfc_find_sym_in_symtree (sym);
3274 c->ext.actual = actual;
3280 /* Make sure that the interface just parsed is not already present in
3281 the given interface list. Ambiguity isn't checked yet since module
3282 procedures can be present without interfaces. */
3285 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
3289 for (ip = base; ip; ip = ip->next)
3291 if (ip->sym == new_sym)
3293 gfc_error ("Entity '%s' at %C is already present in the interface",
3303 /* Add a symbol to the current interface. */
3306 gfc_add_interface (gfc_symbol *new_sym)
3308 gfc_interface **head, *intr;
3312 switch (current_interface.type)
3314 case INTERFACE_NAMELESS:
3315 case INTERFACE_ABSTRACT:
3318 case INTERFACE_INTRINSIC_OP:
3319 for (ns = current_interface.ns; ns; ns = ns->parent)
3320 switch (current_interface.op)
3323 case INTRINSIC_EQ_OS:
3324 if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
3325 check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
3330 case INTRINSIC_NE_OS:
3331 if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
3332 check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
3337 case INTRINSIC_GT_OS:
3338 if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
3339 check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
3344 case INTRINSIC_GE_OS:
3345 if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
3346 check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
3351 case INTRINSIC_LT_OS:
3352 if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
3353 check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
3358 case INTRINSIC_LE_OS:
3359 if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
3360 check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3365 if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3369 head = ¤t_interface.ns->op[current_interface.op];
3372 case INTERFACE_GENERIC:
3373 for (ns = current_interface.ns; ns; ns = ns->parent)
3375 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3379 if (check_new_interface (sym->generic, new_sym) == FAILURE)
3383 head = ¤t_interface.sym->generic;
3386 case INTERFACE_USER_OP:
3387 if (check_new_interface (current_interface.uop->op, new_sym)
3391 head = ¤t_interface.uop->op;
3395 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3398 intr = gfc_get_interface ();
3399 intr->sym = new_sym;
3400 intr->where = gfc_current_locus;
3410 gfc_current_interface_head (void)
3412 switch (current_interface.type)
3414 case INTERFACE_INTRINSIC_OP:
3415 return current_interface.ns->op[current_interface.op];
3418 case INTERFACE_GENERIC:
3419 return current_interface.sym->generic;
3422 case INTERFACE_USER_OP:
3423 return current_interface.uop->op;
3433 gfc_set_current_interface_head (gfc_interface *i)
3435 switch (current_interface.type)
3437 case INTERFACE_INTRINSIC_OP:
3438 current_interface.ns->op[current_interface.op] = i;
3441 case INTERFACE_GENERIC:
3442 current_interface.sym->generic = i;
3445 case INTERFACE_USER_OP:
3446 current_interface.uop->op = i;
3455 /* Gets rid of a formal argument list. We do not free symbols.
3456 Symbols are freed when a namespace is freed. */
3459 gfc_free_formal_arglist (gfc_formal_arglist *p)
3461 gfc_formal_arglist *q;
3471 /* Check that it is ok for the typebound procedure proc to override the
3475 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3478 const gfc_symbol* proc_target;
3479 const gfc_symbol* old_target;
3480 unsigned proc_pass_arg, old_pass_arg, argpos;
3481 gfc_formal_arglist* proc_formal;
3482 gfc_formal_arglist* old_formal;
3484 /* This procedure should only be called for non-GENERIC proc. */
3485 gcc_assert (!proc->n.tb->is_generic);
3487 /* If the overwritten procedure is GENERIC, this is an error. */
3488 if (old->n.tb->is_generic)
3490 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3491 old->name, &proc->n.tb->where);
3495 where = proc->n.tb->where;
3496 proc_target = proc->n.tb->u.specific->n.sym;
3497 old_target = old->n.tb->u.specific->n.sym;
3499 /* Check that overridden binding is not NON_OVERRIDABLE. */
3500 if (old->n.tb->non_overridable)
3502 gfc_error ("'%s' at %L overrides a procedure binding declared"
3503 " NON_OVERRIDABLE", proc->name, &where);
3507 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3508 if (!old->n.tb->deferred && proc->n.tb->deferred)
3510 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3511 " non-DEFERRED binding", proc->name, &where);
3515 /* If the overridden binding is PURE, the overriding must be, too. */
3516 if (old_target->attr.pure && !proc_target->attr.pure)
3518 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3519 proc->name, &where);
3523 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3524 is not, the overriding must not be either. */
3525 if (old_target->attr.elemental && !proc_target->attr.elemental)
3527 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3528 " ELEMENTAL", proc->name, &where);
3531 if (!old_target->attr.elemental && proc_target->attr.elemental)
3533 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3534 " be ELEMENTAL, either", proc->name, &where);
3538 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3540 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
3542 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3543 " SUBROUTINE", proc->name, &where);
3547 /* If the overridden binding is a FUNCTION, the overriding must also be a
3548 FUNCTION and have the same characteristics. */
3549 if (old_target->attr.function)
3551 if (!proc_target->attr.function)
3553 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3554 " FUNCTION", proc->name, &where);
3558 /* FIXME: Do more comprehensive checking (including, for instance, the
3559 rank and array-shape). */
3560 gcc_assert (proc_target->result && old_target->result);
3561 if (!gfc_compare_types (&proc_target->result->ts,
3562 &old_target->result->ts))
3564 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3565 " matching result types", proc->name, &where);
3570 /* If the overridden binding is PUBLIC, the overriding one must not be
3572 if (old->n.tb->access == ACCESS_PUBLIC
3573 && proc->n.tb->access == ACCESS_PRIVATE)
3575 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3576 " PRIVATE", proc->name, &where);
3580 /* Compare the formal argument lists of both procedures. This is also abused
3581 to find the position of the passed-object dummy arguments of both
3582 bindings as at least the overridden one might not yet be resolved and we
3583 need those positions in the check below. */
3584 proc_pass_arg = old_pass_arg = 0;
3585 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
3587 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
3590 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
3591 proc_formal && old_formal;
3592 proc_formal = proc_formal->next, old_formal = old_formal->next)
3594 if (proc->n.tb->pass_arg
3595 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
3596 proc_pass_arg = argpos;
3597 if (old->n.tb->pass_arg
3598 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
3599 old_pass_arg = argpos;
3601 /* Check that the names correspond. */
3602 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
3604 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3605 " to match the corresponding argument of the overridden"
3606 " procedure", proc_formal->sym->name, proc->name, &where,
3607 old_formal->sym->name);
3611 /* Check that the types correspond if neither is the passed-object
3613 /* FIXME: Do more comprehensive testing here. */
3614 if (proc_pass_arg != argpos && old_pass_arg != argpos
3615 && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
3617 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
3618 "in respect to the overridden procedure",
3619 proc_formal->sym->name, proc->name, &where);
3625 if (proc_formal || old_formal)
3627 gfc_error ("'%s' at %L must have the same number of formal arguments as"
3628 " the overridden procedure", proc->name, &where);
3632 /* If the overridden binding is NOPASS, the overriding one must also be
3634 if (old->n.tb->nopass && !proc->n.tb->nopass)
3636 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3637 " NOPASS", proc->name, &where);
3641 /* If the overridden binding is PASS(x), the overriding one must also be
3642 PASS and the passed-object dummy arguments must correspond. */
3643 if (!old->n.tb->nopass)
3645 if (proc->n.tb->nopass)
3647 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3648 " PASS", proc->name, &where);
3652 if (proc_pass_arg != old_pass_arg)
3654 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3655 " the same position as the passed-object dummy argument of"
3656 " the overridden procedure", proc->name, &where);