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. */
70 #include "coretypes.h"
75 /* The current_interface structure holds information about the
76 interface currently being parsed. This structure is saved and
77 restored during recursive interfaces. */
79 gfc_interface_info current_interface;
82 /* Free a singly linked list of gfc_interface structures. */
85 gfc_free_interface (gfc_interface *intr)
89 for (; intr; intr = next)
97 /* Change the operators unary plus and minus into binary plus and
98 minus respectively, leaving the rest unchanged. */
100 static gfc_intrinsic_op
101 fold_unary_intrinsic (gfc_intrinsic_op op)
105 case INTRINSIC_UPLUS:
108 case INTRINSIC_UMINUS:
109 op = INTRINSIC_MINUS;
119 /* Match a generic specification. Depending on which type of
120 interface is found, the 'name' or 'op' pointers may be set.
121 This subroutine doesn't return MATCH_NO. */
124 gfc_match_generic_spec (interface_type *type,
126 gfc_intrinsic_op *op)
128 char buffer[GFC_MAX_SYMBOL_LEN + 1];
132 if (gfc_match (" assignment ( = )") == MATCH_YES)
134 *type = INTERFACE_INTRINSIC_OP;
135 *op = INTRINSIC_ASSIGN;
139 if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
141 *type = INTERFACE_INTRINSIC_OP;
142 *op = fold_unary_intrinsic (i);
146 *op = INTRINSIC_NONE;
147 if (gfc_match (" operator ( ") == MATCH_YES)
149 m = gfc_match_defined_op_name (buffer, 1);
155 m = gfc_match_char (')');
161 strcpy (name, buffer);
162 *type = INTERFACE_USER_OP;
166 if (gfc_match_name (buffer) == MATCH_YES)
168 strcpy (name, buffer);
169 *type = INTERFACE_GENERIC;
173 *type = INTERFACE_NAMELESS;
177 gfc_error ("Syntax error in generic specification at %C");
182 /* Match one of the five F95 forms of an interface statement. The
183 matcher for the abstract interface follows. */
186 gfc_match_interface (void)
188 char name[GFC_MAX_SYMBOL_LEN + 1];
194 m = gfc_match_space ();
196 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
199 /* If we're not looking at the end of the statement now, or if this
200 is not a nameless interface but we did not see a space, punt. */
201 if (gfc_match_eos () != MATCH_YES
202 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
204 gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
209 current_interface.type = type;
213 case INTERFACE_GENERIC:
214 if (gfc_get_symbol (name, NULL, &sym))
217 if (!sym->attr.generic
218 && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
223 gfc_error ("Dummy procedure '%s' at %C cannot have a "
224 "generic interface", sym->name);
228 current_interface.sym = gfc_new_block = sym;
231 case INTERFACE_USER_OP:
232 current_interface.uop = gfc_get_uop (name);
235 case INTERFACE_INTRINSIC_OP:
236 current_interface.op = op;
239 case INTERFACE_NAMELESS:
240 case INTERFACE_ABSTRACT:
249 /* Match a F2003 abstract interface. */
252 gfc_match_abstract_interface (void)
256 if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")
260 m = gfc_match_eos ();
264 gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
268 current_interface.type = INTERFACE_ABSTRACT;
274 /* Match the different sort of generic-specs that can be present after
275 the END INTERFACE itself. */
278 gfc_match_end_interface (void)
280 char name[GFC_MAX_SYMBOL_LEN + 1];
285 m = gfc_match_space ();
287 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
290 /* If we're not looking at the end of the statement now, or if this
291 is not a nameless interface but we did not see a space, punt. */
292 if (gfc_match_eos () != MATCH_YES
293 || (type != INTERFACE_NAMELESS && m != MATCH_YES))
295 gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
302 switch (current_interface.type)
304 case INTERFACE_NAMELESS:
305 case INTERFACE_ABSTRACT:
306 if (type != INTERFACE_NAMELESS)
308 gfc_error ("Expected a nameless interface at %C");
314 case INTERFACE_INTRINSIC_OP:
315 if (type != current_interface.type || op != current_interface.op)
318 if (current_interface.op == INTRINSIC_ASSIGN)
321 gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
326 s1 = gfc_op2string (current_interface.op);
327 s2 = gfc_op2string (op);
329 /* The following if-statements are used to enforce C1202
331 if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
332 || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
334 if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
335 || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
337 if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
338 || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
340 if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
341 || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
343 if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
344 || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
346 if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
347 || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
351 gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
352 "but got %s", s1, s2);
359 case INTERFACE_USER_OP:
360 /* Comparing the symbol node names is OK because only use-associated
361 symbols can be renamed. */
362 if (type != current_interface.type
363 || strcmp (current_interface.uop->name, name) != 0)
365 gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
366 current_interface.uop->name);
372 case INTERFACE_GENERIC:
373 if (type != current_interface.type
374 || strcmp (current_interface.sym->name, name) != 0)
376 gfc_error ("Expecting 'END INTERFACE %s' at %C",
377 current_interface.sym->name);
388 /* Compare two derived types using the criteria in 4.4.2 of the standard,
389 recursing through gfc_compare_types for the components. */
392 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
394 gfc_component *dt1, *dt2;
396 if (derived1 == derived2)
399 /* Special case for comparing derived types across namespaces. If the
400 true names and module names are the same and the module name is
401 nonnull, then they are equal. */
402 if (derived1 != NULL && derived2 != NULL
403 && strcmp (derived1->name, derived2->name) == 0
404 && derived1->module != NULL && derived2->module != NULL
405 && strcmp (derived1->module, derived2->module) == 0)
408 /* Compare type via the rules of the standard. Both types must have
409 the SEQUENCE or BIND(C) attribute to be equal. */
411 if (strcmp (derived1->name, derived2->name))
414 if (derived1->component_access == ACCESS_PRIVATE
415 || derived2->component_access == ACCESS_PRIVATE)
418 if (!(derived1->attr.sequence && derived2->attr.sequence)
419 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
422 dt1 = derived1->components;
423 dt2 = derived2->components;
425 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
426 simple test can speed things up. Otherwise, lots of things have to
430 if (strcmp (dt1->name, dt2->name) != 0)
433 if (dt1->attr.access != dt2->attr.access)
436 if (dt1->attr.pointer != dt2->attr.pointer)
439 if (dt1->attr.dimension != dt2->attr.dimension)
442 if (dt1->attr.allocatable != dt2->attr.allocatable)
445 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
448 /* Make sure that link lists do not put this function into an
449 endless recursive loop! */
450 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
451 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
452 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
455 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
456 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
459 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
460 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
466 if (dt1 == NULL && dt2 == NULL)
468 if (dt1 == NULL || dt2 == NULL)
476 /* Compare two typespecs, recursively if necessary. */
479 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
481 /* See if one of the typespecs is a BT_VOID, which is what is being used
482 to allow the funcs like c_f_pointer to accept any pointer type.
483 TODO: Possibly should narrow this to just the one typespec coming in
484 that is for the formal arg, but oh well. */
485 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
488 if (ts1->type != ts2->type
489 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
490 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
492 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
493 return (ts1->kind == ts2->kind);
495 /* Compare derived types. */
496 if (gfc_type_compatible (ts1, ts2))
499 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
503 /* Given two symbols that are formal arguments, compare their ranks
504 and types. Returns nonzero if they have the same rank and type,
508 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
512 r1 = (s1->as != NULL) ? s1->as->rank : 0;
513 r2 = (s2->as != NULL) ? s2->as->rank : 0;
516 return 0; /* Ranks differ. */
518 return gfc_compare_types (&s1->ts, &s2->ts)
519 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
523 /* Given two symbols that are formal arguments, compare their types
524 and rank and their formal interfaces if they are both dummy
525 procedures. Returns nonzero if the same, zero if different. */
528 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
530 if (s1 == NULL || s2 == NULL)
531 return s1 == s2 ? 1 : 0;
536 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
537 return compare_type_rank (s1, s2);
539 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
542 /* At this point, both symbols are procedures. It can happen that
543 external procedures are compared, where one is identified by usage
544 to be a function or subroutine but the other is not. Check TKR
545 nonetheless for these cases. */
546 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
547 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
549 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
550 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
552 /* Now the type of procedure has been identified. */
553 if (s1->attr.function != s2->attr.function
554 || s1->attr.subroutine != s2->attr.subroutine)
557 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
560 /* Originally, gfortran recursed here to check the interfaces of passed
561 procedures. This is explicitly not required by the standard. */
566 /* Given a formal argument list and a keyword name, search the list
567 for that keyword. Returns the correct symbol node if found, NULL
571 find_keyword_arg (const char *name, gfc_formal_arglist *f)
573 for (; f; f = f->next)
574 if (strcmp (f->sym->name, name) == 0)
581 /******** Interface checking subroutines **********/
584 /* Given an operator interface and the operator, make sure that all
585 interfaces for that operator are legal. */
588 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
591 gfc_formal_arglist *formal;
594 int args, r1, r2, k1, k2;
599 t1 = t2 = BT_UNKNOWN;
600 i1 = i2 = INTENT_UNKNOWN;
604 for (formal = sym->formal; formal; formal = formal->next)
606 gfc_symbol *fsym = formal->sym;
609 gfc_error ("Alternate return cannot appear in operator "
610 "interface at %L", &sym->declared_at);
616 i1 = fsym->attr.intent;
617 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
623 i2 = fsym->attr.intent;
624 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
630 /* Only +, - and .not. can be unary operators.
631 .not. cannot be a binary operator. */
632 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
633 && op != INTRINSIC_MINUS
634 && op != INTRINSIC_NOT)
635 || (args == 2 && op == INTRINSIC_NOT))
637 gfc_error ("Operator interface at %L has the wrong number of arguments",
642 /* Check that intrinsics are mapped to functions, except
643 INTRINSIC_ASSIGN which should map to a subroutine. */
644 if (op == INTRINSIC_ASSIGN)
646 if (!sym->attr.subroutine)
648 gfc_error ("Assignment operator interface at %L must be "
649 "a SUBROUTINE", &sym->declared_at);
654 gfc_error ("Assignment operator interface at %L must have "
655 "two arguments", &sym->declared_at);
659 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
660 - First argument an array with different rank than second,
661 - First argument is a scalar and second an array,
662 - Types and kinds do not conform, or
663 - First argument is of derived type. */
664 if (sym->formal->sym->ts.type != BT_DERIVED
665 && sym->formal->sym->ts.type != BT_CLASS
666 && (r2 == 0 || r1 == r2)
667 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
668 || (gfc_numeric_ts (&sym->formal->sym->ts)
669 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
671 gfc_error ("Assignment operator interface at %L must not redefine "
672 "an INTRINSIC type assignment", &sym->declared_at);
678 if (!sym->attr.function)
680 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
686 /* Check intents on operator interfaces. */
687 if (op == INTRINSIC_ASSIGN)
689 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
691 gfc_error ("First argument of defined assignment at %L must be "
692 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
698 gfc_error ("Second argument of defined assignment at %L must be "
699 "INTENT(IN)", &sym->declared_at);
707 gfc_error ("First argument of operator interface at %L must be "
708 "INTENT(IN)", &sym->declared_at);
712 if (args == 2 && i2 != INTENT_IN)
714 gfc_error ("Second argument of operator interface at %L must be "
715 "INTENT(IN)", &sym->declared_at);
720 /* From now on, all we have to do is check that the operator definition
721 doesn't conflict with an intrinsic operator. The rules for this
722 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
723 as well as 12.3.2.1.1 of Fortran 2003:
725 "If the operator is an intrinsic-operator (R310), the number of
726 function arguments shall be consistent with the intrinsic uses of
727 that operator, and the types, kind type parameters, or ranks of the
728 dummy arguments shall differ from those required for the intrinsic
729 operation (7.1.2)." */
731 #define IS_NUMERIC_TYPE(t) \
732 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
734 /* Unary ops are easy, do them first. */
735 if (op == INTRINSIC_NOT)
737 if (t1 == BT_LOGICAL)
743 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
745 if (IS_NUMERIC_TYPE (t1))
751 /* Character intrinsic operators have same character kind, thus
752 operator definitions with operands of different character kinds
754 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
757 /* Intrinsic operators always perform on arguments of same rank,
758 so different ranks is also always safe. (rank == 0) is an exception
759 to that, because all intrinsic operators are elemental. */
760 if (r1 != r2 && r1 != 0 && r2 != 0)
766 case INTRINSIC_EQ_OS:
768 case INTRINSIC_NE_OS:
769 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
774 case INTRINSIC_MINUS:
775 case INTRINSIC_TIMES:
776 case INTRINSIC_DIVIDE:
777 case INTRINSIC_POWER:
778 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
783 case INTRINSIC_GT_OS:
785 case INTRINSIC_GE_OS:
787 case INTRINSIC_LT_OS:
789 case INTRINSIC_LE_OS:
790 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
792 if ((t1 == BT_INTEGER || t1 == BT_REAL)
793 && (t2 == BT_INTEGER || t2 == BT_REAL))
797 case INTRINSIC_CONCAT:
798 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
806 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
816 #undef IS_NUMERIC_TYPE
819 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
825 /* Given a pair of formal argument lists, we see if the two lists can
826 be distinguished by counting the number of nonoptional arguments of
827 a given type/rank in f1 and seeing if there are less then that
828 number of those arguments in f2 (including optional arguments).
829 Since this test is asymmetric, it has to be called twice to make it
830 symmetric. Returns nonzero if the argument lists are incompatible
831 by this test. This subroutine implements rule 1 of section F03:16.2.3.
832 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
835 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
836 const char *p1, const char *p2)
838 int rc, ac1, ac2, i, j, k, n1;
839 gfc_formal_arglist *f;
852 for (f = f1; f; f = f->next)
855 /* Build an array of integers that gives the same integer to
856 arguments of the same type/rank. */
857 arg = XCNEWVEC (arginfo, n1);
860 for (i = 0; i < n1; i++, f = f->next)
868 for (i = 0; i < n1; i++)
870 if (arg[i].flag != -1)
873 if (arg[i].sym && (arg[i].sym->attr.optional
874 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
875 continue; /* Skip OPTIONAL and PASS arguments. */
879 /* Find other non-optional, non-pass arguments of the same type/rank. */
880 for (j = i + 1; j < n1; j++)
881 if ((arg[j].sym == NULL
882 || !(arg[j].sym->attr.optional
883 || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
884 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
885 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
891 /* Now loop over each distinct type found in f1. */
895 for (i = 0; i < n1; i++)
897 if (arg[i].flag != k)
901 for (j = i + 1; j < n1; j++)
902 if (arg[j].flag == k)
905 /* Count the number of non-pass arguments in f2 with that type,
906 including those that are optional. */
909 for (f = f2; f; f = f->next)
910 if ((!p2 || strcmp (f->sym->name, p2) != 0)
911 && (compare_type_rank_if (arg[i].sym, f->sym)
912 || compare_type_rank_if (f->sym, arg[i].sym)))
930 /* Perform the correspondence test in rule 3 of section F03:16.2.3.
931 Returns zero if no argument is found that satisfies rule 3, nonzero
932 otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
935 This test is also not symmetric in f1 and f2 and must be called
936 twice. This test finds problems caused by sorting the actual
937 argument list with keywords. For example:
941 INTEGER :: A ; REAL :: B
945 INTEGER :: A ; REAL :: B
949 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
952 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
953 const char *p1, const char *p2)
955 gfc_formal_arglist *f2_save, *g;
962 if (f1->sym->attr.optional)
965 if (p1 && strcmp (f1->sym->name, p1) == 0)
967 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
970 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
971 || compare_type_rank (f2->sym, f1->sym)))
974 /* Now search for a disambiguating keyword argument starting at
975 the current non-match. */
976 for (g = f1; g; g = g->next)
978 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
981 sym = find_keyword_arg (g->sym->name, f2_save);
982 if (sym == NULL || !compare_type_rank (g->sym, sym))
997 /* Check if the characteristics of two dummy arguments match,
1001 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1002 bool type_must_agree, char *errmsg, int err_len)
1004 /* Check type and rank. */
1005 if (type_must_agree && !compare_type_rank (s2, s1))
1008 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1014 if (s1->attr.intent != s2->attr.intent)
1016 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1021 /* Check OPTIONAL attribute. */
1022 if (s1->attr.optional != s2->attr.optional)
1024 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1029 /* Check ALLOCATABLE attribute. */
1030 if (s1->attr.allocatable != s2->attr.allocatable)
1032 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1037 /* Check POINTER attribute. */
1038 if (s1->attr.pointer != s2->attr.pointer)
1040 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1045 /* Check TARGET attribute. */
1046 if (s1->attr.target != s2->attr.target)
1048 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1053 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1054 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1056 /* Check string length. */
1057 if (s1->ts.type == BT_CHARACTER
1058 && s1->ts.u.cl && s1->ts.u.cl->length
1059 && s2->ts.u.cl && s2->ts.u.cl->length)
1061 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1062 s2->ts.u.cl->length);
1068 snprintf (errmsg, err_len, "Character length mismatch "
1069 "in argument '%s'", s1->name);
1073 /* FIXME: Implement a warning for this case.
1074 gfc_warning ("Possible character length mismatch in argument '%s'",
1082 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1083 "%i of gfc_dep_compare_expr", compval);
1088 /* Check array shape. */
1089 if (s1->as && s2->as)
1092 gfc_expr *shape1, *shape2;
1094 if (s1->as->type != s2->as->type)
1096 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1101 if (s1->as->type == AS_EXPLICIT)
1102 for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1104 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1105 gfc_copy_expr (s1->as->lower[i]));
1106 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1107 gfc_copy_expr (s2->as->lower[i]));
1108 compval = gfc_dep_compare_expr (shape1, shape2);
1109 gfc_free_expr (shape1);
1110 gfc_free_expr (shape2);
1116 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1117 "argument '%s'", i + 1, s1->name);
1121 /* FIXME: Implement a warning for this case.
1122 gfc_warning ("Possible shape mismatch in argument '%s'",
1130 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1131 "result %i of gfc_dep_compare_expr",
1142 /* 'Compare' two formal interfaces associated with a pair of symbols.
1143 We return nonzero if there exists an actual argument list that
1144 would be ambiguous between the two interfaces, zero otherwise.
1145 'strict_flag' specifies whether all the characteristics are
1146 required to match, which is not the case for ambiguity checks.
1147 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1150 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1151 int generic_flag, int strict_flag,
1152 char *errmsg, int err_len,
1153 const char *p1, const char *p2)
1155 gfc_formal_arglist *f1, *f2;
1157 gcc_assert (name2 != NULL);
1159 if (s1->attr.function && (s2->attr.subroutine
1160 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1161 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1164 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1168 if (s1->attr.subroutine && s2->attr.function)
1171 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1175 /* Do strict checks on all characteristics
1176 (for dummy procedures and procedure pointer assignments). */
1177 if (!generic_flag && strict_flag)
1179 if (s1->attr.function && s2->attr.function)
1181 /* If both are functions, check result type. */
1182 if (s1->ts.type == BT_UNKNOWN)
1184 if (!compare_type_rank (s1,s2))
1187 snprintf (errmsg, err_len, "Type/rank mismatch in return value "
1192 /* FIXME: Check array bounds and string length of result. */
1195 if (s1->attr.pure && !s2->attr.pure)
1197 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1200 if (s1->attr.elemental && !s2->attr.elemental)
1202 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1207 if (s1->attr.if_source == IFSRC_UNKNOWN
1208 || s2->attr.if_source == IFSRC_UNKNOWN)
1214 if (f1 == NULL && f2 == NULL)
1215 return 1; /* Special case: No arguments. */
1219 if (count_types_test (f1, f2, p1, p2)
1220 || count_types_test (f2, f1, p2, p1))
1222 if (generic_correspondence (f1, f2, p1, p2)
1223 || generic_correspondence (f2, f1, p2, p1))
1227 /* Perform the abbreviated correspondence test for operators (the
1228 arguments cannot be optional and are always ordered correctly).
1229 This is also done when comparing interfaces for dummy procedures and in
1230 procedure pointer assignments. */
1234 /* Check existence. */
1235 if (f1 == NULL && f2 == NULL)
1237 if (f1 == NULL || f2 == NULL)
1240 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1241 "arguments", name2);
1247 /* Check all characteristics. */
1248 if (check_dummy_characteristics (f1->sym, f2->sym,
1249 true, errmsg, err_len) == FAILURE)
1252 else if (!compare_type_rank (f2->sym, f1->sym))
1254 /* Only check type and rank. */
1256 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1269 /* Given a pointer to an interface pointer, remove duplicate
1270 interfaces and make sure that all symbols are either functions
1271 or subroutines, and all of the same kind. Returns nonzero if
1272 something goes wrong. */
1275 check_interface0 (gfc_interface *p, const char *interface_name)
1277 gfc_interface *psave, *q, *qlast;
1280 for (; p; p = p->next)
1282 /* Make sure all symbols in the interface have been defined as
1283 functions or subroutines. */
1284 if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1285 || !p->sym->attr.if_source)
1286 && p->sym->attr.flavor != FL_DERIVED)
1288 if (p->sym->attr.external)
1289 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1290 p->sym->name, interface_name, &p->sym->declared_at);
1292 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1293 "subroutine", p->sym->name, interface_name,
1294 &p->sym->declared_at);
1298 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1299 if ((psave->sym->attr.function && !p->sym->attr.function
1300 && p->sym->attr.flavor != FL_DERIVED)
1301 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1303 if (p->sym->attr.flavor != FL_DERIVED)
1304 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1305 " or all FUNCTIONs", interface_name,
1306 &p->sym->declared_at);
1308 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1309 "generic name is also the name of a derived type",
1310 interface_name, &p->sym->declared_at);
1314 /* F2003, C1207. F2008, C1207. */
1315 if (p->sym->attr.proc == PROC_INTERNAL
1316 && gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1317 "'%s' in %s at %L", p->sym->name, interface_name,
1318 &p->sym->declared_at) == FAILURE)
1323 /* Remove duplicate interfaces in this interface list. */
1324 for (; p; p = p->next)
1328 for (q = p->next; q;)
1330 if (p->sym != q->sym)
1337 /* Duplicate interface. */
1338 qlast->next = q->next;
1349 /* Check lists of interfaces to make sure that no two interfaces are
1350 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1353 check_interface1 (gfc_interface *p, gfc_interface *q0,
1354 int generic_flag, const char *interface_name,
1358 for (; p; p = p->next)
1359 for (q = q0; q; q = q->next)
1361 if (p->sym == q->sym)
1362 continue; /* Duplicates OK here. */
1364 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1367 if (p->sym->attr.flavor != FL_DERIVED
1368 && q->sym->attr.flavor != FL_DERIVED
1369 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1370 generic_flag, 0, NULL, 0, NULL, NULL))
1373 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1374 p->sym->name, q->sym->name, interface_name,
1376 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1377 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1378 p->sym->name, q->sym->name, interface_name,
1381 gfc_warning ("Although not referenced, '%s' has ambiguous "
1382 "interfaces at %L", interface_name, &p->where);
1390 /* Check the generic and operator interfaces of symbols to make sure
1391 that none of the interfaces conflict. The check has to be done
1392 after all of the symbols are actually loaded. */
1395 check_sym_interfaces (gfc_symbol *sym)
1397 char interface_name[100];
1400 if (sym->ns != gfc_current_ns)
1403 if (sym->generic != NULL)
1405 sprintf (interface_name, "generic interface '%s'", sym->name);
1406 if (check_interface0 (sym->generic, interface_name))
1409 for (p = sym->generic; p; p = p->next)
1411 if (sym->attr.access != ACCESS_PRIVATE)
1412 p->sym->attr.public_used = 1;
1414 if (p->sym->attr.mod_proc
1415 && (p->sym->attr.if_source != IFSRC_DECL
1416 || p->sym->attr.procedure))
1418 gfc_error ("'%s' at %L is not a module procedure",
1419 p->sym->name, &p->where);
1424 /* Originally, this test was applied to host interfaces too;
1425 this is incorrect since host associated symbols, from any
1426 source, cannot be ambiguous with local symbols. */
1427 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1428 sym->attr.referenced || !sym->attr.use_assoc);
1434 check_uop_interfaces (gfc_user_op *uop)
1436 char interface_name[100];
1441 sprintf (interface_name, "operator interface '%s'", uop->name);
1442 if (check_interface0 (uop->op, interface_name))
1445 if (uop->access != ACCESS_PRIVATE)
1446 for (p = uop->op; p; p = p->next)
1447 p->sym->attr.public_used = 1;
1449 for (ns = gfc_current_ns; ns; ns = ns->parent)
1451 uop2 = gfc_find_uop (uop->name, ns);
1455 check_interface1 (uop->op, uop2->op, 0,
1456 interface_name, true);
1460 /* Given an intrinsic op, return an equivalent op if one exists,
1461 or INTRINSIC_NONE otherwise. */
1464 gfc_equivalent_op (gfc_intrinsic_op op)
1469 return INTRINSIC_EQ_OS;
1471 case INTRINSIC_EQ_OS:
1472 return INTRINSIC_EQ;
1475 return INTRINSIC_NE_OS;
1477 case INTRINSIC_NE_OS:
1478 return INTRINSIC_NE;
1481 return INTRINSIC_GT_OS;
1483 case INTRINSIC_GT_OS:
1484 return INTRINSIC_GT;
1487 return INTRINSIC_GE_OS;
1489 case INTRINSIC_GE_OS:
1490 return INTRINSIC_GE;
1493 return INTRINSIC_LT_OS;
1495 case INTRINSIC_LT_OS:
1496 return INTRINSIC_LT;
1499 return INTRINSIC_LE_OS;
1501 case INTRINSIC_LE_OS:
1502 return INTRINSIC_LE;
1505 return INTRINSIC_NONE;
1509 /* For the namespace, check generic, user operator and intrinsic
1510 operator interfaces for consistency and to remove duplicate
1511 interfaces. We traverse the whole namespace, counting on the fact
1512 that most symbols will not have generic or operator interfaces. */
1515 gfc_check_interfaces (gfc_namespace *ns)
1517 gfc_namespace *old_ns, *ns2;
1519 char interface_name[100];
1522 old_ns = gfc_current_ns;
1523 gfc_current_ns = ns;
1525 gfc_traverse_ns (ns, check_sym_interfaces);
1527 gfc_traverse_user_op (ns, check_uop_interfaces);
1529 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1531 if (i == INTRINSIC_USER)
1534 if (i == INTRINSIC_ASSIGN)
1535 strcpy (interface_name, "intrinsic assignment operator");
1537 sprintf (interface_name, "intrinsic '%s' operator",
1538 gfc_op2string ((gfc_intrinsic_op) i));
1540 if (check_interface0 (ns->op[i], interface_name))
1543 for (p = ns->op[i]; p; p = p->next)
1544 p->sym->attr.public_used = 1;
1548 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1551 for (ns2 = ns; ns2; ns2 = ns2->parent)
1553 gfc_intrinsic_op other_op;
1555 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1556 interface_name, true))
1559 /* i should be gfc_intrinsic_op, but has to be int with this cast
1560 here for stupid C++ compatibility rules. */
1561 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1562 if (other_op != INTRINSIC_NONE
1563 && check_interface1 (ns->op[i], ns2->op[other_op],
1564 0, interface_name, true))
1570 gfc_current_ns = old_ns;
1575 symbol_rank (gfc_symbol *sym)
1577 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1578 return CLASS_DATA (sym)->as->rank;
1580 return (sym->as == NULL) ? 0 : sym->as->rank;
1584 /* Given a symbol of a formal argument list and an expression, if the
1585 formal argument is allocatable, check that the actual argument is
1586 allocatable. Returns nonzero if compatible, zero if not compatible. */
1589 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1591 symbol_attribute attr;
1593 if (formal->attr.allocatable
1594 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1596 attr = gfc_expr_attr (actual);
1597 if (!attr.allocatable)
1605 /* Given a symbol of a formal argument list and an expression, if the
1606 formal argument is a pointer, see if the actual argument is a
1607 pointer. Returns nonzero if compatible, zero if not compatible. */
1610 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1612 symbol_attribute attr;
1614 if (formal->attr.pointer
1615 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
1616 && CLASS_DATA (formal)->attr.class_pointer))
1618 attr = gfc_expr_attr (actual);
1620 /* Fortran 2008 allows non-pointer actual arguments. */
1621 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1632 /* Emit clear error messages for rank mismatch. */
1635 argument_rank_mismatch (const char *name, locus *where,
1636 int rank1, int rank2)
1640 gfc_error ("Rank mismatch in argument '%s' at %L "
1641 "(scalar and rank-%d)", name, where, rank2);
1643 else if (rank2 == 0)
1645 gfc_error ("Rank mismatch in argument '%s' at %L "
1646 "(rank-%d and scalar)", name, where, rank1);
1650 gfc_error ("Rank mismatch in argument '%s' at %L "
1651 "(rank-%d and rank-%d)", name, where, rank1, rank2);
1656 /* Given a symbol of a formal argument list and an expression, see if
1657 the two are compatible as arguments. Returns nonzero if
1658 compatible, zero if not compatible. */
1661 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1662 int ranks_must_agree, int is_elemental, locus *where)
1665 bool rank_check, is_pointer;
1667 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1668 procs c_f_pointer or c_f_procpointer, and we need to accept most
1669 pointers the user could give us. This should allow that. */
1670 if (formal->ts.type == BT_VOID)
1673 if (formal->ts.type == BT_DERIVED
1674 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1675 && actual->ts.type == BT_DERIVED
1676 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1679 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1680 /* Make sure the vtab symbol is present when
1681 the module variables are generated. */
1682 gfc_find_derived_vtab (actual->ts.u.derived);
1684 if (actual->ts.type == BT_PROCEDURE)
1687 gfc_symbol *act_sym = actual->symtree->n.sym;
1689 if (formal->attr.flavor != FL_PROCEDURE)
1692 gfc_error ("Invalid procedure argument at %L", &actual->where);
1696 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1697 sizeof(err), NULL, NULL))
1700 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1701 formal->name, &actual->where, err);
1705 if (formal->attr.function && !act_sym->attr.function)
1707 gfc_add_function (&act_sym->attr, act_sym->name,
1708 &act_sym->declared_at);
1709 if (act_sym->ts.type == BT_UNKNOWN
1710 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1713 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1714 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1715 &act_sym->declared_at);
1721 if (formal->attr.pointer && formal->attr.contiguous
1722 && !gfc_is_simply_contiguous (actual, true))
1725 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1726 "must be simply contigous", formal->name, &actual->where);
1730 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1731 && actual->ts.type != BT_HOLLERITH
1732 && formal->ts.type != BT_ASSUMED
1733 && !gfc_compare_types (&formal->ts, &actual->ts)
1734 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
1735 && gfc_compare_derived_types (formal->ts.u.derived,
1736 CLASS_DATA (actual)->ts.u.derived)))
1739 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1740 formal->name, &actual->where, gfc_typename (&actual->ts),
1741 gfc_typename (&formal->ts));
1745 /* F2008, 12.5.2.5; IR F08/0073. */
1746 if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
1747 && ((CLASS_DATA (formal)->attr.class_pointer
1748 && !formal->attr.intent == INTENT_IN)
1749 || CLASS_DATA (formal)->attr.allocatable))
1751 if (actual->ts.type != BT_CLASS)
1754 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1755 formal->name, &actual->where);
1758 if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
1759 CLASS_DATA (formal)->ts.u.derived))
1762 gfc_error ("Actual argument to '%s' at %L must have the same "
1763 "declared type", formal->name, &actual->where);
1768 if (formal->attr.codimension && !gfc_is_coarray (actual))
1771 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1772 formal->name, &actual->where);
1776 if (formal->attr.codimension && formal->attr.allocatable)
1778 gfc_ref *last = NULL;
1780 for (ref = actual->ref; ref; ref = ref->next)
1781 if (ref->type == REF_COMPONENT)
1784 /* F2008, 12.5.2.6. */
1785 if ((last && last->u.c.component->as->corank != formal->as->corank)
1787 && actual->symtree->n.sym->as->corank != formal->as->corank))
1790 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1791 formal->name, &actual->where, formal->as->corank,
1792 last ? last->u.c.component->as->corank
1793 : actual->symtree->n.sym->as->corank);
1798 if (formal->attr.codimension)
1800 /* F2008, 12.5.2.8. */
1801 if (formal->attr.dimension
1802 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1803 && gfc_expr_attr (actual).dimension
1804 && !gfc_is_simply_contiguous (actual, true))
1807 gfc_error ("Actual argument to '%s' at %L must be simply "
1808 "contiguous", formal->name, &actual->where);
1812 /* F2008, C1303 and C1304. */
1813 if (formal->attr.intent != INTENT_INOUT
1814 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1815 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1816 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1817 || formal->attr.lock_comp))
1821 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1822 "which is LOCK_TYPE or has a LOCK_TYPE component",
1823 formal->name, &actual->where);
1828 /* F2008, C1239/C1240. */
1829 if (actual->expr_type == EXPR_VARIABLE
1830 && (actual->symtree->n.sym->attr.asynchronous
1831 || actual->symtree->n.sym->attr.volatile_)
1832 && (formal->attr.asynchronous || formal->attr.volatile_)
1833 && actual->rank && !gfc_is_simply_contiguous (actual, true)
1834 && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1835 || formal->attr.contiguous))
1838 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1839 "array without CONTIGUOUS attribute - as actual argument at"
1840 " %L is not simply contiguous and both are ASYNCHRONOUS "
1841 "or VOLATILE", formal->name, &actual->where);
1845 if (formal->attr.allocatable && !formal->attr.codimension
1846 && gfc_expr_attr (actual).codimension)
1848 if (formal->attr.intent == INTENT_OUT)
1851 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
1852 "INTENT(OUT) dummy argument '%s'", &actual->where,
1856 else if (gfc_option.warn_surprising && where
1857 && formal->attr.intent != INTENT_IN)
1858 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
1859 "argument '%s', which is invalid if the allocation status"
1860 " is modified", &actual->where, formal->name);
1863 if (symbol_rank (formal) == actual->rank)
1866 if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
1867 && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
1870 rank_check = where != NULL && !is_elemental && formal->as
1871 && (formal->as->type == AS_ASSUMED_SHAPE
1872 || formal->as->type == AS_DEFERRED)
1873 && actual->expr_type != EXPR_NULL;
1875 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
1876 if (rank_check || ranks_must_agree
1877 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1878 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1879 || (actual->rank == 0
1880 && ((formal->ts.type == BT_CLASS
1881 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
1882 || (formal->ts.type != BT_CLASS
1883 && formal->as->type == AS_ASSUMED_SHAPE))
1884 && actual->expr_type != EXPR_NULL)
1885 || (actual->rank == 0 && formal->attr.dimension
1886 && gfc_is_coindexed (actual)))
1889 argument_rank_mismatch (formal->name, &actual->where,
1890 symbol_rank (formal), actual->rank);
1893 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1896 /* At this point, we are considering a scalar passed to an array. This
1897 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
1898 - if the actual argument is (a substring of) an element of a
1899 non-assumed-shape/non-pointer/non-polymorphic array; or
1900 - (F2003) if the actual argument is of type character of default/c_char
1903 is_pointer = actual->expr_type == EXPR_VARIABLE
1904 ? actual->symtree->n.sym->attr.pointer : false;
1906 for (ref = actual->ref; ref; ref = ref->next)
1908 if (ref->type == REF_COMPONENT)
1909 is_pointer = ref->u.c.component->attr.pointer;
1910 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1911 && ref->u.ar.dimen > 0
1913 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
1917 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
1920 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
1921 "at %L", formal->name, &actual->where);
1925 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
1926 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1929 gfc_error ("Element of assumed-shaped or pointer "
1930 "array passed to array dummy argument '%s' at %L",
1931 formal->name, &actual->where);
1935 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
1936 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
1938 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
1941 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
1942 "CHARACTER actual argument with array dummy argument "
1943 "'%s' at %L", formal->name, &actual->where);
1947 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1949 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1950 "array dummy argument '%s' at %L",
1951 formal->name, &actual->where);
1954 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1960 if (ref == NULL && actual->expr_type != EXPR_NULL)
1963 argument_rank_mismatch (formal->name, &actual->where,
1964 symbol_rank (formal), actual->rank);
1972 /* Returns the storage size of a symbol (formal argument) or
1973 zero if it cannot be determined. */
1975 static unsigned long
1976 get_sym_storage_size (gfc_symbol *sym)
1979 unsigned long strlen, elements;
1981 if (sym->ts.type == BT_CHARACTER)
1983 if (sym->ts.u.cl && sym->ts.u.cl->length
1984 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1985 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1992 if (symbol_rank (sym) == 0)
1996 if (sym->as->type != AS_EXPLICIT)
1998 for (i = 0; i < sym->as->rank; i++)
2000 if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
2001 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2004 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2005 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2008 return strlen*elements;
2012 /* Returns the storage size of an expression (actual argument) or
2013 zero if it cannot be determined. For an array element, it returns
2014 the remaining size as the element sequence consists of all storage
2015 units of the actual argument up to the end of the array. */
2017 static unsigned long
2018 get_expr_storage_size (gfc_expr *e)
2021 long int strlen, elements;
2022 long int substrlen = 0;
2023 bool is_str_storage = false;
2029 if (e->ts.type == BT_CHARACTER)
2031 if (e->ts.u.cl && e->ts.u.cl->length
2032 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2033 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2034 else if (e->expr_type == EXPR_CONSTANT
2035 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2036 strlen = e->value.character.length;
2041 strlen = 1; /* Length per element. */
2043 if (e->rank == 0 && !e->ref)
2051 for (i = 0; i < e->rank; i++)
2052 elements *= mpz_get_si (e->shape[i]);
2053 return elements*strlen;
2056 for (ref = e->ref; ref; ref = ref->next)
2058 if (ref->type == REF_SUBSTRING && ref->u.ss.start
2059 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2063 /* The string length is the substring length.
2064 Set now to full string length. */
2065 if (!ref->u.ss.length || !ref->u.ss.length->length
2066 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2069 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2071 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2075 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
2076 && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
2077 && ref->u.ar.as->upper)
2078 for (i = 0; i < ref->u.ar.dimen; i++)
2080 long int start, end, stride;
2083 if (ref->u.ar.stride[i])
2085 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2086 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2091 if (ref->u.ar.start[i])
2093 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2094 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2098 else if (ref->u.ar.as->lower[i]
2099 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2100 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2104 if (ref->u.ar.end[i])
2106 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2107 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2111 else if (ref->u.ar.as->upper[i]
2112 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2113 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2117 elements *= (end - start)/stride + 1L;
2119 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
2120 && ref->u.ar.as->lower && ref->u.ar.as->upper)
2121 for (i = 0; i < ref->u.ar.as->rank; i++)
2123 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2124 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2125 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2126 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2127 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2132 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2133 && e->expr_type == EXPR_VARIABLE)
2135 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2136 || e->symtree->n.sym->attr.pointer)
2142 /* Determine the number of remaining elements in the element
2143 sequence for array element designators. */
2144 is_str_storage = true;
2145 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2147 if (ref->u.ar.start[i] == NULL
2148 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2149 || ref->u.ar.as->upper[i] == NULL
2150 || ref->u.ar.as->lower[i] == NULL
2151 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2152 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2157 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2158 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2160 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2161 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2167 return (is_str_storage) ? substrlen + (elements-1)*strlen
2170 return elements*strlen;
2174 /* Given an expression, check whether it is an array section
2175 which has a vector subscript. If it has, one is returned,
2179 gfc_has_vector_subscript (gfc_expr *e)
2184 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2187 for (ref = e->ref; ref; ref = ref->next)
2188 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2189 for (i = 0; i < ref->u.ar.dimen; i++)
2190 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2197 /* Given formal and actual argument lists, see if they are compatible.
2198 If they are compatible, the actual argument list is sorted to
2199 correspond with the formal list, and elements for missing optional
2200 arguments are inserted. If WHERE pointer is nonnull, then we issue
2201 errors when things don't match instead of just returning the status
2205 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2206 int ranks_must_agree, int is_elemental, locus *where)
2208 gfc_actual_arglist **new_arg, *a, *actual, temp;
2209 gfc_formal_arglist *f;
2211 unsigned long actual_size, formal_size;
2212 bool full_array = false;
2216 if (actual == NULL && formal == NULL)
2220 for (f = formal; f; f = f->next)
2223 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2225 for (i = 0; i < n; i++)
2232 for (a = actual; a; a = a->next, f = f->next)
2234 /* Look for keywords but ignore g77 extensions like %VAL. */
2235 if (a->name != NULL && a->name[0] != '%')
2238 for (f = formal; f; f = f->next, i++)
2242 if (strcmp (f->sym->name, a->name) == 0)
2249 gfc_error ("Keyword argument '%s' at %L is not in "
2250 "the procedure", a->name, &a->expr->where);
2254 if (new_arg[i] != NULL)
2257 gfc_error ("Keyword argument '%s' at %L is already associated "
2258 "with another actual argument", a->name,
2267 gfc_error ("More actual than formal arguments in procedure "
2268 "call at %L", where);
2273 if (f->sym == NULL && a->expr == NULL)
2279 gfc_error ("Missing alternate return spec in subroutine call "
2284 if (a->expr == NULL)
2287 gfc_error ("Unexpected alternate return spec in subroutine "
2288 "call at %L", where);
2292 if (a->expr->expr_type == EXPR_NULL
2293 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
2294 && (f->sym->attr.allocatable || !f->sym->attr.optional
2295 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2296 || (f->sym->ts.type == BT_CLASS
2297 && !CLASS_DATA (f->sym)->attr.class_pointer
2298 && (CLASS_DATA (f->sym)->attr.allocatable
2299 || !f->sym->attr.optional
2300 || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
2303 && (!f->sym->attr.optional
2304 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
2305 || (f->sym->ts.type == BT_CLASS
2306 && CLASS_DATA (f->sym)->attr.allocatable)))
2307 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2308 where, f->sym->name);
2310 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2311 "dummy '%s'", where, f->sym->name);
2316 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2317 is_elemental, where))
2320 /* TS 29113, 6.3p2. */
2321 if (f->sym->ts.type == BT_ASSUMED
2322 && (a->expr->ts.type == BT_DERIVED
2323 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2325 gfc_namespace *f2k_derived;
2327 f2k_derived = a->expr->ts.type == BT_DERIVED
2328 ? a->expr->ts.u.derived->f2k_derived
2329 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2332 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
2334 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2335 "derived type with type-bound or FINAL procedures",
2341 /* Special case for character arguments. For allocatable, pointer
2342 and assumed-shape dummies, the string length needs to match
2344 if (a->expr->ts.type == BT_CHARACTER
2345 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2346 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2347 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2348 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2349 && (f->sym->attr.pointer || f->sym->attr.allocatable
2350 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2351 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2352 f->sym->ts.u.cl->length->value.integer) != 0))
2354 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2355 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2356 "argument and pointer or allocatable dummy argument "
2358 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2359 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2360 f->sym->name, &a->expr->where);
2362 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2363 "argument and assumed-shape dummy argument '%s' "
2365 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2366 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2367 f->sym->name, &a->expr->where);
2371 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2372 && f->sym->ts.deferred != a->expr->ts.deferred
2373 && a->expr->ts.type == BT_CHARACTER)
2376 gfc_error ("Actual argument at %L to allocatable or "
2377 "pointer dummy argument '%s' must have a deferred "
2378 "length type parameter if and only if the dummy has one",
2379 &a->expr->where, f->sym->name);
2383 if (f->sym->ts.type == BT_CLASS)
2384 goto skip_size_check;
2386 actual_size = get_expr_storage_size (a->expr);
2387 formal_size = get_sym_storage_size (f->sym);
2388 if (actual_size != 0 && actual_size < formal_size
2389 && a->expr->ts.type != BT_PROCEDURE
2390 && f->sym->attr.flavor != FL_PROCEDURE)
2392 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2393 gfc_warning ("Character length of actual argument shorter "
2394 "than of dummy argument '%s' (%lu/%lu) at %L",
2395 f->sym->name, actual_size, formal_size,
2398 gfc_warning ("Actual argument contains too few "
2399 "elements for dummy argument '%s' (%lu/%lu) at %L",
2400 f->sym->name, actual_size, formal_size,
2407 /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2408 is provided for a procedure pointer formal argument. */
2409 if (f->sym->attr.proc_pointer
2410 && !((a->expr->expr_type == EXPR_VARIABLE
2411 && a->expr->symtree->n.sym->attr.proc_pointer)
2412 || (a->expr->expr_type == EXPR_FUNCTION
2413 && a->expr->symtree->n.sym->result->attr.proc_pointer)
2414 || gfc_is_proc_ptr_comp (a->expr, NULL)))
2417 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2418 f->sym->name, &a->expr->where);
2422 /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2423 provided for a procedure formal argument. */
2424 if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2425 && a->expr->expr_type == EXPR_VARIABLE
2426 && f->sym->attr.flavor == FL_PROCEDURE)
2429 gfc_error ("Expected a procedure for argument '%s' at %L",
2430 f->sym->name, &a->expr->where);
2434 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2435 && a->expr->expr_type == EXPR_VARIABLE
2436 && a->expr->symtree->n.sym->as
2437 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2438 && (a->expr->ref == NULL
2439 || (a->expr->ref->type == REF_ARRAY
2440 && a->expr->ref->u.ar.type == AR_FULL)))
2443 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2444 " array at %L", f->sym->name, where);
2448 if (a->expr->expr_type != EXPR_NULL
2449 && compare_pointer (f->sym, a->expr) == 0)
2452 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2453 f->sym->name, &a->expr->where);
2457 if (a->expr->expr_type != EXPR_NULL
2458 && (gfc_option.allow_std & GFC_STD_F2008) == 0
2459 && compare_pointer (f->sym, a->expr) == 2)
2462 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2463 "pointer dummy '%s'", &a->expr->where,f->sym->name);
2468 /* Fortran 2008, C1242. */
2469 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2472 gfc_error ("Coindexed actual argument at %L to pointer "
2474 &a->expr->where, f->sym->name);
2478 /* Fortran 2008, 12.5.2.5 (no constraint). */
2479 if (a->expr->expr_type == EXPR_VARIABLE
2480 && f->sym->attr.intent != INTENT_IN
2481 && f->sym->attr.allocatable
2482 && gfc_is_coindexed (a->expr))
2485 gfc_error ("Coindexed actual argument at %L to allocatable "
2486 "dummy '%s' requires INTENT(IN)",
2487 &a->expr->where, f->sym->name);
2491 /* Fortran 2008, C1237. */
2492 if (a->expr->expr_type == EXPR_VARIABLE
2493 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2494 && gfc_is_coindexed (a->expr)
2495 && (a->expr->symtree->n.sym->attr.volatile_
2496 || a->expr->symtree->n.sym->attr.asynchronous))
2499 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2500 "%L requires that dummy '%s' has neither "
2501 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2506 /* Fortran 2008, 12.5.2.4 (no constraint). */
2507 if (a->expr->expr_type == EXPR_VARIABLE
2508 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2509 && gfc_is_coindexed (a->expr)
2510 && gfc_has_ultimate_allocatable (a->expr))
2513 gfc_error ("Coindexed actual argument at %L with allocatable "
2514 "ultimate component to dummy '%s' requires either VALUE "
2515 "or INTENT(IN)", &a->expr->where, f->sym->name);
2519 if (f->sym->ts.type == BT_CLASS
2520 && CLASS_DATA (f->sym)->attr.allocatable
2521 && gfc_is_class_array_ref (a->expr, &full_array)
2525 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2526 "array at %L", f->sym->name, &a->expr->where);
2531 if (a->expr->expr_type != EXPR_NULL
2532 && compare_allocatable (f->sym, a->expr) == 0)
2535 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2536 f->sym->name, &a->expr->where);
2540 /* Check intent = OUT/INOUT for definable actual argument. */
2541 if ((f->sym->attr.intent == INTENT_OUT
2542 || f->sym->attr.intent == INTENT_INOUT))
2544 const char* context = (where
2545 ? _("actual argument to INTENT = OUT/INOUT")
2548 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2549 && CLASS_DATA (f->sym)->attr.class_pointer)
2550 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2551 && gfc_check_vardef_context (a->expr, true, false, context)
2554 if (gfc_check_vardef_context (a->expr, false, false, context)
2559 if ((f->sym->attr.intent == INTENT_OUT
2560 || f->sym->attr.intent == INTENT_INOUT
2561 || f->sym->attr.volatile_
2562 || f->sym->attr.asynchronous)
2563 && gfc_has_vector_subscript (a->expr))
2566 gfc_error ("Array-section actual argument with vector "
2567 "subscripts at %L is incompatible with INTENT(OUT), "
2568 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2569 "of the dummy argument '%s'",
2570 &a->expr->where, f->sym->name);
2574 /* C1232 (R1221) For an actual argument which is an array section or
2575 an assumed-shape array, the dummy argument shall be an assumed-
2576 shape array, if the dummy argument has the VOLATILE attribute. */
2578 if (f->sym->attr.volatile_
2579 && a->expr->symtree->n.sym->as
2580 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2581 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2584 gfc_error ("Assumed-shape actual argument at %L is "
2585 "incompatible with the non-assumed-shape "
2586 "dummy argument '%s' due to VOLATILE attribute",
2587 &a->expr->where,f->sym->name);
2591 if (f->sym->attr.volatile_
2592 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2593 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2596 gfc_error ("Array-section actual argument at %L is "
2597 "incompatible with the non-assumed-shape "
2598 "dummy argument '%s' due to VOLATILE attribute",
2599 &a->expr->where,f->sym->name);
2603 /* C1233 (R1221) For an actual argument which is a pointer array, the
2604 dummy argument shall be an assumed-shape or pointer array, if the
2605 dummy argument has the VOLATILE attribute. */
2607 if (f->sym->attr.volatile_
2608 && a->expr->symtree->n.sym->attr.pointer
2609 && a->expr->symtree->n.sym->as
2611 && (f->sym->as->type == AS_ASSUMED_SHAPE
2612 || f->sym->attr.pointer)))
2615 gfc_error ("Pointer-array actual argument at %L requires "
2616 "an assumed-shape or pointer-array dummy "
2617 "argument '%s' due to VOLATILE attribute",
2618 &a->expr->where,f->sym->name);
2629 /* Make sure missing actual arguments are optional. */
2631 for (f = formal; f; f = f->next, i++)
2633 if (new_arg[i] != NULL)
2638 gfc_error ("Missing alternate return spec in subroutine call "
2642 if (!f->sym->attr.optional)
2645 gfc_error ("Missing actual argument for argument '%s' at %L",
2646 f->sym->name, where);
2651 /* The argument lists are compatible. We now relink a new actual
2652 argument list with null arguments in the right places. The head
2653 of the list remains the head. */
2654 for (i = 0; i < n; i++)
2655 if (new_arg[i] == NULL)
2656 new_arg[i] = gfc_get_actual_arglist ();
2661 *new_arg[0] = *actual;
2665 new_arg[0] = new_arg[na];
2669 for (i = 0; i < n - 1; i++)
2670 new_arg[i]->next = new_arg[i + 1];
2672 new_arg[i]->next = NULL;
2674 if (*ap == NULL && n > 0)
2677 /* Note the types of omitted optional arguments. */
2678 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2679 if (a->expr == NULL && a->label == NULL)
2680 a->missing_arg_type = f->sym->ts.type;
2688 gfc_formal_arglist *f;
2689 gfc_actual_arglist *a;
2693 /* qsort comparison function for argument pairs, with the following
2695 - p->a->expr == NULL
2696 - p->a->expr->expr_type != EXPR_VARIABLE
2697 - growing p->a->expr->symbol. */
2700 pair_cmp (const void *p1, const void *p2)
2702 const gfc_actual_arglist *a1, *a2;
2704 /* *p1 and *p2 are elements of the to-be-sorted array. */
2705 a1 = ((const argpair *) p1)->a;
2706 a2 = ((const argpair *) p2)->a;
2715 if (a1->expr->expr_type != EXPR_VARIABLE)
2717 if (a2->expr->expr_type != EXPR_VARIABLE)
2721 if (a2->expr->expr_type != EXPR_VARIABLE)
2723 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2727 /* Given two expressions from some actual arguments, test whether they
2728 refer to the same expression. The analysis is conservative.
2729 Returning FAILURE will produce no warning. */
2732 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2734 const gfc_ref *r1, *r2;
2737 || e1->expr_type != EXPR_VARIABLE
2738 || e2->expr_type != EXPR_VARIABLE
2739 || e1->symtree->n.sym != e2->symtree->n.sym)
2742 /* TODO: improve comparison, see expr.c:show_ref(). */
2743 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2745 if (r1->type != r2->type)
2750 if (r1->u.ar.type != r2->u.ar.type)
2752 /* TODO: At the moment, consider only full arrays;
2753 we could do better. */
2754 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2759 if (r1->u.c.component != r2->u.c.component)
2767 gfc_internal_error ("compare_actual_expr(): Bad component code");
2776 /* Given formal and actual argument lists that correspond to one
2777 another, check that identical actual arguments aren't not
2778 associated with some incompatible INTENTs. */
2781 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2783 sym_intent f1_intent, f2_intent;
2784 gfc_formal_arglist *f1;
2785 gfc_actual_arglist *a1;
2788 gfc_try t = SUCCESS;
2791 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2793 if (f1 == NULL && a1 == NULL)
2795 if (f1 == NULL || a1 == NULL)
2796 gfc_internal_error ("check_some_aliasing(): List mismatch");
2801 p = XALLOCAVEC (argpair, n);
2803 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2809 qsort (p, n, sizeof (argpair), pair_cmp);
2811 for (i = 0; i < n; i++)
2814 || p[i].a->expr->expr_type != EXPR_VARIABLE
2815 || p[i].a->expr->ts.type == BT_PROCEDURE)
2817 f1_intent = p[i].f->sym->attr.intent;
2818 for (j = i + 1; j < n; j++)
2820 /* Expected order after the sort. */
2821 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2822 gfc_internal_error ("check_some_aliasing(): corrupted data");
2824 /* Are the expression the same? */
2825 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2827 f2_intent = p[j].f->sym->attr.intent;
2828 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2829 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2831 gfc_warning ("Same actual argument associated with INTENT(%s) "
2832 "argument '%s' and INTENT(%s) argument '%s' at %L",
2833 gfc_intent_string (f1_intent), p[i].f->sym->name,
2834 gfc_intent_string (f2_intent), p[j].f->sym->name,
2835 &p[i].a->expr->where);
2845 /* Given formal and actual argument lists that correspond to one
2846 another, check that they are compatible in the sense that intents
2847 are not mismatched. */
2850 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2852 sym_intent f_intent;
2854 for (;; f = f->next, a = a->next)
2856 if (f == NULL && a == NULL)
2858 if (f == NULL || a == NULL)
2859 gfc_internal_error ("check_intents(): List mismatch");
2861 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2864 f_intent = f->sym->attr.intent;
2866 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2868 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2869 && CLASS_DATA (f->sym)->attr.class_pointer)
2870 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2872 gfc_error ("Procedure argument at %L is local to a PURE "
2873 "procedure and has the POINTER attribute",
2879 /* Fortran 2008, C1283. */
2880 if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2882 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2884 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2885 "is passed to an INTENT(%s) argument",
2886 &a->expr->where, gfc_intent_string (f_intent));
2890 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2891 && CLASS_DATA (f->sym)->attr.class_pointer)
2892 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2894 gfc_error ("Coindexed actual argument at %L in PURE procedure "
2895 "is passed to a POINTER dummy argument",
2901 /* F2008, Section 12.5.2.4. */
2902 if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2903 && gfc_is_coindexed (a->expr))
2905 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2906 "polymorphic dummy argument '%s'",
2907 &a->expr->where, f->sym->name);
2916 /* Check how a procedure is used against its interface. If all goes
2917 well, the actual argument list will also end up being properly
2921 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2923 /* Warn about calls with an implicit interface. Special case
2924 for calling a ISO_C_BINDING becase c_loc and c_funloc
2925 are pseudo-unknown. Additionally, warn about procedures not
2926 explicitly declared at all if requested. */
2927 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2929 if (gfc_option.warn_implicit_interface)
2930 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2932 else if (gfc_option.warn_implicit_procedure
2933 && sym->attr.proc == PROC_UNKNOWN)
2934 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2938 if (sym->attr.if_source == IFSRC_UNKNOWN)
2940 gfc_actual_arglist *a;
2942 if (sym->attr.pointer)
2944 gfc_error("The pointer object '%s' at %L must have an explicit "
2945 "function interface or be declared as array",
2950 if (sym->attr.allocatable && !sym->attr.external)
2952 gfc_error("The allocatable object '%s' at %L must have an explicit "
2953 "function interface or be declared as array",
2958 if (sym->attr.allocatable)
2960 gfc_error("Allocatable function '%s' at %L must have an explicit "
2961 "function interface", sym->name, where);
2965 for (a = *ap; a; a = a->next)
2967 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
2968 if (a->name != NULL && a->name[0] != '%')
2970 gfc_error("Keyword argument requires explicit interface "
2971 "for procedure '%s' at %L", sym->name, &a->expr->where);
2975 /* TS 29113, 6.2. */
2976 if (a->expr && a->expr->ts.type == BT_ASSUMED
2977 && sym->intmod_sym_id != ISOCBINDING_LOC)
2979 gfc_error ("Assumed-type argument %s at %L requires an explicit "
2980 "interface", a->expr->symtree->n.sym->name,
2985 /* F2008, C1303 and C1304. */
2987 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
2988 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2989 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2990 || gfc_expr_attr (a->expr).lock_comp))
2992 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
2993 "component at %L requires an explicit interface for "
2994 "procedure '%s'", &a->expr->where, sym->name);
2998 if (a->expr && a->expr->expr_type == EXPR_NULL
2999 && a->expr->ts.type == BT_UNKNOWN)
3001 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3009 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
3012 check_intents (sym->formal, *ap);
3013 if (gfc_option.warn_aliasing)
3014 check_some_aliasing (sym->formal, *ap);
3018 /* Check how a procedure pointer component is used against its interface.
3019 If all goes well, the actual argument list will also end up being properly
3020 sorted. Completely analogous to gfc_procedure_use. */
3023 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3026 /* Warn about calls with an implicit interface. Special case
3027 for calling a ISO_C_BINDING becase c_loc and c_funloc
3028 are pseudo-unknown. */
3029 if (gfc_option.warn_implicit_interface
3030 && comp->attr.if_source == IFSRC_UNKNOWN
3031 && !comp->attr.is_iso_c)
3032 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3033 "interface at %L", comp->name, where);
3035 if (comp->attr.if_source == IFSRC_UNKNOWN)
3037 gfc_actual_arglist *a;
3038 for (a = *ap; a; a = a->next)
3040 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3041 if (a->name != NULL && a->name[0] != '%')
3043 gfc_error("Keyword argument requires explicit interface "
3044 "for procedure pointer component '%s' at %L",
3045 comp->name, &a->expr->where);
3053 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
3056 check_intents (comp->formal, *ap);
3057 if (gfc_option.warn_aliasing)
3058 check_some_aliasing (comp->formal, *ap);
3062 /* Try if an actual argument list matches the formal list of a symbol,
3063 respecting the symbol's attributes like ELEMENTAL. This is used for
3064 GENERIC resolution. */
3067 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3071 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
3073 r = !sym->attr.elemental;
3074 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
3076 check_intents (sym->formal, *args);
3077 if (gfc_option.warn_aliasing)
3078 check_some_aliasing (sym->formal, *args);
3086 /* Given an interface pointer and an actual argument list, search for
3087 a formal argument list that matches the actual. If found, returns
3088 a pointer to the symbol of the correct interface. Returns NULL if
3092 gfc_search_interface (gfc_interface *intr, int sub_flag,
3093 gfc_actual_arglist **ap)
3095 gfc_symbol *elem_sym = NULL;
3096 gfc_symbol *null_sym = NULL;
3097 locus null_expr_loc;
3098 gfc_actual_arglist *a;
3099 bool has_null_arg = false;
3101 for (a = *ap; a; a = a->next)
3102 if (a->expr && a->expr->expr_type == EXPR_NULL
3103 && a->expr->ts.type == BT_UNKNOWN)
3105 has_null_arg = true;
3106 null_expr_loc = a->expr->where;
3110 for (; intr; intr = intr->next)
3112 if (intr->sym->attr.flavor == FL_DERIVED)
3114 if (sub_flag && intr->sym->attr.function)
3116 if (!sub_flag && intr->sym->attr.subroutine)
3119 if (gfc_arglist_matches_symbol (ap, intr->sym))
3121 if (has_null_arg && null_sym)
3123 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3124 "between specific functions %s and %s",
3125 &null_expr_loc, null_sym->name, intr->sym->name);
3128 else if (has_null_arg)
3130 null_sym = intr->sym;
3134 /* Satisfy 12.4.4.1 such that an elemental match has lower
3135 weight than a non-elemental match. */
3136 if (intr->sym->attr.elemental)
3138 elem_sym = intr->sym;
3148 return elem_sym ? elem_sym : NULL;
3152 /* Do a brute force recursive search for a symbol. */
3154 static gfc_symtree *
3155 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3159 if (root->n.sym == sym)
3164 st = find_symtree0 (root->left, sym);
3165 if (root->right && ! st)
3166 st = find_symtree0 (root->right, sym);
3171 /* Find a symtree for a symbol. */
3174 gfc_find_sym_in_symtree (gfc_symbol *sym)
3179 /* First try to find it by name. */
3180 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3181 if (st && st->n.sym == sym)
3184 /* If it's been renamed, resort to a brute-force search. */
3185 /* TODO: avoid having to do this search. If the symbol doesn't exist
3186 in the symtree for the current namespace, it should probably be added. */
3187 for (ns = gfc_current_ns; ns; ns = ns->parent)
3189 st = find_symtree0 (ns->sym_root, sym);
3193 gfc_internal_error ("Unable to find symbol %s", sym->name);
3198 /* See if the arglist to an operator-call contains a derived-type argument
3199 with a matching type-bound operator. If so, return the matching specific
3200 procedure defined as operator-target as well as the base-object to use
3201 (which is the found derived-type argument with operator). The generic
3202 name, if any, is transmitted to the final expression via 'gname'. */
3204 static gfc_typebound_proc*
3205 matching_typebound_op (gfc_expr** tb_base,
3206 gfc_actual_arglist* args,
3207 gfc_intrinsic_op op, const char* uop,
3208 const char ** gname)
3210 gfc_actual_arglist* base;
3212 for (base = args; base; base = base->next)
3213 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3215 gfc_typebound_proc* tb;
3216 gfc_symbol* derived;
3219 while (base->expr->expr_type == EXPR_OP
3220 && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3221 base->expr = base->expr->value.op.op1;
3223 if (base->expr->ts.type == BT_CLASS)
3225 if (CLASS_DATA (base->expr) == NULL)
3227 derived = CLASS_DATA (base->expr)->ts.u.derived;
3230 derived = base->expr->ts.u.derived;
3232 if (op == INTRINSIC_USER)
3234 gfc_symtree* tb_uop;
3237 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3246 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3249 /* This means we hit a PRIVATE operator which is use-associated and
3250 should thus not be seen. */
3251 if (result == FAILURE)
3254 /* Look through the super-type hierarchy for a matching specific
3256 for (; tb; tb = tb->overridden)
3260 gcc_assert (tb->is_generic);
3261 for (g = tb->u.generic; g; g = g->next)
3264 gfc_actual_arglist* argcopy;
3267 gcc_assert (g->specific);
3268 if (g->specific->error)
3271 target = g->specific->u.specific->n.sym;
3273 /* Check if this arglist matches the formal. */
3274 argcopy = gfc_copy_actual_arglist (args);
3275 matches = gfc_arglist_matches_symbol (&argcopy, target);
3276 gfc_free_actual_arglist (argcopy);
3278 /* Return if we found a match. */
3281 *tb_base = base->expr;
3282 *gname = g->specific_st->name;
3293 /* For the 'actual arglist' of an operator call and a specific typebound
3294 procedure that has been found the target of a type-bound operator, build the
3295 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3296 type-bound procedures rather than resolving type-bound operators 'directly'
3297 so that we can reuse the existing logic. */
3300 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3301 gfc_expr* base, gfc_typebound_proc* target,
3304 e->expr_type = EXPR_COMPCALL;
3305 e->value.compcall.tbp = target;
3306 e->value.compcall.name = gname ? gname : "$op";
3307 e->value.compcall.actual = actual;
3308 e->value.compcall.base_object = base;
3309 e->value.compcall.ignore_pass = 1;
3310 e->value.compcall.assign = 0;
3311 if (e->ts.type == BT_UNKNOWN
3312 && target->function)
3314 if (target->is_generic)
3315 e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3317 e->ts = target->u.specific->n.sym->ts;
3322 /* This subroutine is called when an expression is being resolved.
3323 The expression node in question is either a user defined operator
3324 or an intrinsic operator with arguments that aren't compatible
3325 with the operator. This subroutine builds an actual argument list
3326 corresponding to the operands, then searches for a compatible
3327 interface. If one is found, the expression node is replaced with
3328 the appropriate function call. We use the 'match' enum to specify
3329 whether a replacement has been made or not, or if an error occurred. */
3332 gfc_extend_expr (gfc_expr *e)
3334 gfc_actual_arglist *actual;
3343 actual = gfc_get_actual_arglist ();
3344 actual->expr = e->value.op.op1;
3348 if (e->value.op.op2 != NULL)
3350 actual->next = gfc_get_actual_arglist ();
3351 actual->next->expr = e->value.op.op2;
3354 i = fold_unary_intrinsic (e->value.op.op);
3356 if (i == INTRINSIC_USER)
3358 for (ns = gfc_current_ns; ns; ns = ns->parent)
3360 uop = gfc_find_uop (e->value.op.uop->name, ns);
3364 sym = gfc_search_interface (uop->op, 0, &actual);
3371 for (ns = gfc_current_ns; ns; ns = ns->parent)
3373 /* Due to the distinction between '==' and '.eq.' and friends, one has
3374 to check if either is defined. */
3377 #define CHECK_OS_COMPARISON(comp) \
3378 case INTRINSIC_##comp: \
3379 case INTRINSIC_##comp##_OS: \
3380 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3382 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3384 CHECK_OS_COMPARISON(EQ)
3385 CHECK_OS_COMPARISON(NE)
3386 CHECK_OS_COMPARISON(GT)
3387 CHECK_OS_COMPARISON(GE)
3388 CHECK_OS_COMPARISON(LT)
3389 CHECK_OS_COMPARISON(LE)
3390 #undef CHECK_OS_COMPARISON
3393 sym = gfc_search_interface (ns->op[i], 0, &actual);
3401 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3402 found rather than just taking the first one and not checking further. */
3406 gfc_typebound_proc* tbo;
3409 /* See if we find a matching type-bound operator. */
3410 if (i == INTRINSIC_USER)
3411 tbo = matching_typebound_op (&tb_base, actual,
3412 i, e->value.op.uop->name, &gname);
3416 #define CHECK_OS_COMPARISON(comp) \
3417 case INTRINSIC_##comp: \
3418 case INTRINSIC_##comp##_OS: \
3419 tbo = matching_typebound_op (&tb_base, actual, \
3420 INTRINSIC_##comp, NULL, &gname); \
3422 tbo = matching_typebound_op (&tb_base, actual, \
3423 INTRINSIC_##comp##_OS, NULL, &gname); \
3425 CHECK_OS_COMPARISON(EQ)
3426 CHECK_OS_COMPARISON(NE)
3427 CHECK_OS_COMPARISON(GT)
3428 CHECK_OS_COMPARISON(GE)
3429 CHECK_OS_COMPARISON(LT)
3430 CHECK_OS_COMPARISON(LE)
3431 #undef CHECK_OS_COMPARISON
3434 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3438 /* If there is a matching typebound-operator, replace the expression with
3439 a call to it and succeed. */
3444 gcc_assert (tb_base);
3445 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3447 result = gfc_resolve_expr (e);
3448 if (result == FAILURE)
3454 /* Don't use gfc_free_actual_arglist(). */
3455 free (actual->next);
3461 /* Change the expression node to a function call. */
3462 e->expr_type = EXPR_FUNCTION;
3463 e->symtree = gfc_find_sym_in_symtree (sym);
3464 e->value.function.actual = actual;
3465 e->value.function.esym = NULL;
3466 e->value.function.isym = NULL;
3467 e->value.function.name = NULL;
3468 e->user_operator = 1;
3470 if (gfc_resolve_expr (e) == FAILURE)
3477 /* Tries to replace an assignment code node with a subroutine call to
3478 the subroutine associated with the assignment operator. Return
3479 SUCCESS if the node was replaced. On FAILURE, no error is
3483 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3485 gfc_actual_arglist *actual;
3486 gfc_expr *lhs, *rhs;
3495 /* Don't allow an intrinsic assignment to be replaced. */
3496 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3497 && (rhs->rank == 0 || rhs->rank == lhs->rank)
3498 && (lhs->ts.type == rhs->ts.type
3499 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3502 actual = gfc_get_actual_arglist ();
3505 actual->next = gfc_get_actual_arglist ();
3506 actual->next->expr = rhs;
3510 for (; ns; ns = ns->parent)
3512 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3517 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3521 gfc_typebound_proc* tbo;
3524 /* See if we find a matching type-bound assignment. */
3525 tbo = matching_typebound_op (&tb_base, actual,
3526 INTRINSIC_ASSIGN, NULL, &gname);
3528 /* If there is one, replace the expression with a call to it and
3532 gcc_assert (tb_base);
3533 c->expr1 = gfc_get_expr ();
3534 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3535 c->expr1->value.compcall.assign = 1;
3536 c->expr1->where = c->loc;
3538 c->op = EXEC_COMPCALL;
3540 /* c is resolved from the caller, so no need to do it here. */
3545 free (actual->next);
3550 /* Replace the assignment with the call. */
3551 c->op = EXEC_ASSIGN_CALL;
3552 c->symtree = gfc_find_sym_in_symtree (sym);
3555 c->ext.actual = actual;
3561 /* Make sure that the interface just parsed is not already present in
3562 the given interface list. Ambiguity isn't checked yet since module
3563 procedures can be present without interfaces. */
3566 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
3570 for (ip = base; ip; ip = ip->next)
3572 if (ip->sym == new_sym)
3574 gfc_error ("Entity '%s' at %L is already present in the interface",
3575 new_sym->name, &loc);
3584 /* Add a symbol to the current interface. */
3587 gfc_add_interface (gfc_symbol *new_sym)
3589 gfc_interface **head, *intr;
3593 switch (current_interface.type)
3595 case INTERFACE_NAMELESS:
3596 case INTERFACE_ABSTRACT:
3599 case INTERFACE_INTRINSIC_OP:
3600 for (ns = current_interface.ns; ns; ns = ns->parent)
3601 switch (current_interface.op)
3604 case INTRINSIC_EQ_OS:
3605 if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
3606 gfc_current_locus) == FAILURE
3607 || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
3608 gfc_current_locus) == FAILURE)
3613 case INTRINSIC_NE_OS:
3614 if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
3615 gfc_current_locus) == FAILURE
3616 || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
3617 gfc_current_locus) == FAILURE)
3622 case INTRINSIC_GT_OS:
3623 if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
3624 gfc_current_locus) == FAILURE
3625 || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
3626 gfc_current_locus) == FAILURE)
3631 case INTRINSIC_GE_OS:
3632 if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
3633 gfc_current_locus) == FAILURE
3634 || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
3635 gfc_current_locus) == FAILURE)
3640 case INTRINSIC_LT_OS:
3641 if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
3642 gfc_current_locus) == FAILURE
3643 || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
3644 gfc_current_locus) == FAILURE)
3649 case INTRINSIC_LE_OS:
3650 if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
3651 gfc_current_locus) == FAILURE
3652 || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
3653 gfc_current_locus) == FAILURE)
3658 if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
3659 gfc_current_locus) == FAILURE)
3663 head = ¤t_interface.ns->op[current_interface.op];
3666 case INTERFACE_GENERIC:
3667 for (ns = current_interface.ns; ns; ns = ns->parent)
3669 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3673 if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
3678 head = ¤t_interface.sym->generic;
3681 case INTERFACE_USER_OP:
3682 if (gfc_check_new_interface (current_interface.uop->op, new_sym,
3683 gfc_current_locus) == FAILURE)
3686 head = ¤t_interface.uop->op;
3690 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3693 intr = gfc_get_interface ();
3694 intr->sym = new_sym;
3695 intr->where = gfc_current_locus;
3705 gfc_current_interface_head (void)
3707 switch (current_interface.type)
3709 case INTERFACE_INTRINSIC_OP:
3710 return current_interface.ns->op[current_interface.op];
3713 case INTERFACE_GENERIC:
3714 return current_interface.sym->generic;
3717 case INTERFACE_USER_OP:
3718 return current_interface.uop->op;
3728 gfc_set_current_interface_head (gfc_interface *i)
3730 switch (current_interface.type)
3732 case INTERFACE_INTRINSIC_OP:
3733 current_interface.ns->op[current_interface.op] = i;
3736 case INTERFACE_GENERIC:
3737 current_interface.sym->generic = i;
3740 case INTERFACE_USER_OP:
3741 current_interface.uop->op = i;
3750 /* Gets rid of a formal argument list. We do not free symbols.
3751 Symbols are freed when a namespace is freed. */
3754 gfc_free_formal_arglist (gfc_formal_arglist *p)
3756 gfc_formal_arglist *q;
3766 /* Check that it is ok for the type-bound procedure 'proc' to override the
3767 procedure 'old', cf. F08:4.5.7.3. */
3770 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3773 const gfc_symbol *proc_target, *old_target;
3774 unsigned proc_pass_arg, old_pass_arg, argpos;
3775 gfc_formal_arglist *proc_formal, *old_formal;
3779 /* This procedure should only be called for non-GENERIC proc. */
3780 gcc_assert (!proc->n.tb->is_generic);
3782 /* If the overwritten procedure is GENERIC, this is an error. */
3783 if (old->n.tb->is_generic)
3785 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3786 old->name, &proc->n.tb->where);
3790 where = proc->n.tb->where;
3791 proc_target = proc->n.tb->u.specific->n.sym;
3792 old_target = old->n.tb->u.specific->n.sym;
3794 /* Check that overridden binding is not NON_OVERRIDABLE. */
3795 if (old->n.tb->non_overridable)
3797 gfc_error ("'%s' at %L overrides a procedure binding declared"
3798 " NON_OVERRIDABLE", proc->name, &where);
3802 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3803 if (!old->n.tb->deferred && proc->n.tb->deferred)
3805 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3806 " non-DEFERRED binding", proc->name, &where);
3810 /* If the overridden binding is PURE, the overriding must be, too. */
3811 if (old_target->attr.pure && !proc_target->attr.pure)
3813 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3814 proc->name, &where);
3818 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3819 is not, the overriding must not be either. */
3820 if (old_target->attr.elemental && !proc_target->attr.elemental)
3822 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
3823 " ELEMENTAL", proc->name, &where);
3826 if (!old_target->attr.elemental && proc_target->attr.elemental)
3828 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
3829 " be ELEMENTAL, either", proc->name, &where);
3833 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
3835 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
3837 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
3838 " SUBROUTINE", proc->name, &where);
3842 /* If the overridden binding is a FUNCTION, the overriding must also be a
3843 FUNCTION and have the same characteristics. */
3844 if (old_target->attr.function)
3846 if (!proc_target->attr.function)
3848 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
3849 " FUNCTION", proc->name, &where);
3853 /* FIXME: Do more comprehensive checking (including, for instance, the
3855 gcc_assert (proc_target->result && old_target->result);
3856 if (!compare_type_rank (proc_target->result, old_target->result))
3858 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
3859 " matching result types and ranks", proc->name, &where);
3863 /* Check string length. */
3864 if (proc_target->result->ts.type == BT_CHARACTER
3865 && proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
3867 int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
3868 old_target->result->ts.u.cl->length);
3874 gfc_error ("Character length mismatch between '%s' at '%L' and "
3875 "overridden FUNCTION", proc->name, &where);
3879 gfc_warning ("Possible character length mismatch between '%s' at"
3880 " '%L' and overridden FUNCTION", proc->name, &where);
3887 gfc_internal_error ("gfc_check_typebound_override: Unexpected "
3888 "result %i of gfc_dep_compare_expr", compval);
3894 /* If the overridden binding is PUBLIC, the overriding one must not be
3896 if (old->n.tb->access == ACCESS_PUBLIC
3897 && proc->n.tb->access == ACCESS_PRIVATE)
3899 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
3900 " PRIVATE", proc->name, &where);
3904 /* Compare the formal argument lists of both procedures. This is also abused
3905 to find the position of the passed-object dummy arguments of both
3906 bindings as at least the overridden one might not yet be resolved and we
3907 need those positions in the check below. */
3908 proc_pass_arg = old_pass_arg = 0;
3909 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
3911 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
3914 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
3915 proc_formal && old_formal;
3916 proc_formal = proc_formal->next, old_formal = old_formal->next)
3918 if (proc->n.tb->pass_arg
3919 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
3920 proc_pass_arg = argpos;
3921 if (old->n.tb->pass_arg
3922 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
3923 old_pass_arg = argpos;
3925 /* Check that the names correspond. */
3926 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
3928 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
3929 " to match the corresponding argument of the overridden"
3930 " procedure", proc_formal->sym->name, proc->name, &where,
3931 old_formal->sym->name);
3935 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
3936 if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
3937 check_type, err, sizeof(err)) == FAILURE)
3939 gfc_error ("Argument mismatch for the overriding procedure "
3940 "'%s' at %L: %s", proc->name, &where, err);
3946 if (proc_formal || old_formal)
3948 gfc_error ("'%s' at %L must have the same number of formal arguments as"
3949 " the overridden procedure", proc->name, &where);
3953 /* If the overridden binding is NOPASS, the overriding one must also be
3955 if (old->n.tb->nopass && !proc->n.tb->nopass)
3957 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
3958 " NOPASS", proc->name, &where);
3962 /* If the overridden binding is PASS(x), the overriding one must also be
3963 PASS and the passed-object dummy arguments must correspond. */
3964 if (!old->n.tb->nopass)
3966 if (proc->n.tb->nopass)
3968 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
3969 " PASS", proc->name, &where);
3973 if (proc_pass_arg != old_pass_arg)
3975 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
3976 " the same position as the passed-object dummy argument of"
3977 " the overridden procedure", proc->name, &where);