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 gcc_assert (derived1 && derived2);
401 /* Special case for comparing derived types across namespaces. If the
402 true names and module names are the same and the module name is
403 nonnull, then they are equal. */
404 if (strcmp (derived1->name, derived2->name) == 0
405 && derived1->module != NULL && derived2->module != NULL
406 && strcmp (derived1->module, derived2->module) == 0)
409 /* Compare type via the rules of the standard. Both types must have
410 the SEQUENCE or BIND(C) attribute to be equal. */
412 if (strcmp (derived1->name, derived2->name))
415 if (derived1->component_access == ACCESS_PRIVATE
416 || derived2->component_access == ACCESS_PRIVATE)
419 if (!(derived1->attr.sequence && derived2->attr.sequence)
420 && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
423 dt1 = derived1->components;
424 dt2 = derived2->components;
426 /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
427 simple test can speed things up. Otherwise, lots of things have to
431 if (strcmp (dt1->name, dt2->name) != 0)
434 if (dt1->attr.access != dt2->attr.access)
437 if (dt1->attr.pointer != dt2->attr.pointer)
440 if (dt1->attr.dimension != dt2->attr.dimension)
443 if (dt1->attr.allocatable != dt2->attr.allocatable)
446 if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
449 /* Make sure that link lists do not put this function into an
450 endless recursive loop! */
451 if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
452 && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
453 && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
456 else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
457 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
460 else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
461 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
467 if (dt1 == NULL && dt2 == NULL)
469 if (dt1 == NULL || dt2 == NULL)
477 /* Compare two typespecs, recursively if necessary. */
480 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
482 /* See if one of the typespecs is a BT_VOID, which is what is being used
483 to allow the funcs like c_f_pointer to accept any pointer type.
484 TODO: Possibly should narrow this to just the one typespec coming in
485 that is for the formal arg, but oh well. */
486 if (ts1->type == BT_VOID || ts2->type == BT_VOID)
489 if (ts1->type == BT_CLASS
490 && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
494 if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
495 && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
496 && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
499 if (ts1->type != ts2->type
500 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
501 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
503 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
504 return (ts1->kind == ts2->kind);
506 /* Compare derived types. */
507 if (gfc_type_compatible (ts1, ts2))
510 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
514 /* Given two symbols that are formal arguments, compare their ranks
515 and types. Returns nonzero if they have the same rank and type,
519 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
521 gfc_array_spec *as1, *as2;
524 as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
525 as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
527 r1 = as1 ? as1->rank : 0;
528 r2 = as2 ? as2->rank : 0;
531 && (!as1 || as1->type != AS_ASSUMED_RANK)
532 && (!as2 || as2->type != AS_ASSUMED_RANK))
533 return 0; /* Ranks differ. */
535 return gfc_compare_types (&s1->ts, &s2->ts)
536 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
540 /* Given two symbols that are formal arguments, compare their types
541 and rank and their formal interfaces if they are both dummy
542 procedures. Returns nonzero if the same, zero if different. */
545 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
547 if (s1 == NULL || s2 == NULL)
548 return s1 == s2 ? 1 : 0;
553 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
554 return compare_type_rank (s1, s2);
556 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
559 /* At this point, both symbols are procedures. It can happen that
560 external procedures are compared, where one is identified by usage
561 to be a function or subroutine but the other is not. Check TKR
562 nonetheless for these cases. */
563 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
564 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
566 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
567 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
569 /* Now the type of procedure has been identified. */
570 if (s1->attr.function != s2->attr.function
571 || s1->attr.subroutine != s2->attr.subroutine)
574 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
577 /* Originally, gfortran recursed here to check the interfaces of passed
578 procedures. This is explicitly not required by the standard. */
583 /* Given a formal argument list and a keyword name, search the list
584 for that keyword. Returns the correct symbol node if found, NULL
588 find_keyword_arg (const char *name, gfc_formal_arglist *f)
590 for (; f; f = f->next)
591 if (strcmp (f->sym->name, name) == 0)
598 /******** Interface checking subroutines **********/
601 /* Given an operator interface and the operator, make sure that all
602 interfaces for that operator are legal. */
605 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
608 gfc_formal_arglist *formal;
611 int args, r1, r2, k1, k2;
616 t1 = t2 = BT_UNKNOWN;
617 i1 = i2 = INTENT_UNKNOWN;
621 for (formal = sym->formal; formal; formal = formal->next)
623 gfc_symbol *fsym = formal->sym;
626 gfc_error ("Alternate return cannot appear in operator "
627 "interface at %L", &sym->declared_at);
633 i1 = fsym->attr.intent;
634 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
640 i2 = fsym->attr.intent;
641 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
647 /* Only +, - and .not. can be unary operators.
648 .not. cannot be a binary operator. */
649 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
650 && op != INTRINSIC_MINUS
651 && op != INTRINSIC_NOT)
652 || (args == 2 && op == INTRINSIC_NOT))
654 if (op == INTRINSIC_ASSIGN)
655 gfc_error ("Assignment operator interface at %L must have "
656 "two arguments", &sym->declared_at);
658 gfc_error ("Operator interface at %L has the wrong number of arguments",
663 /* Check that intrinsics are mapped to functions, except
664 INTRINSIC_ASSIGN which should map to a subroutine. */
665 if (op == INTRINSIC_ASSIGN)
667 if (!sym->attr.subroutine)
669 gfc_error ("Assignment operator interface at %L must be "
670 "a SUBROUTINE", &sym->declared_at);
674 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
675 - First argument an array with different rank than second,
676 - First argument is a scalar and second an array,
677 - Types and kinds do not conform, or
678 - First argument is of derived type. */
679 if (sym->formal->sym->ts.type != BT_DERIVED
680 && sym->formal->sym->ts.type != BT_CLASS
681 && (r2 == 0 || r1 == r2)
682 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
683 || (gfc_numeric_ts (&sym->formal->sym->ts)
684 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
686 gfc_error ("Assignment operator interface at %L must not redefine "
687 "an INTRINSIC type assignment", &sym->declared_at);
693 if (!sym->attr.function)
695 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
701 /* Check intents on operator interfaces. */
702 if (op == INTRINSIC_ASSIGN)
704 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
706 gfc_error ("First argument of defined assignment at %L must be "
707 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
713 gfc_error ("Second argument of defined assignment at %L must be "
714 "INTENT(IN)", &sym->declared_at);
722 gfc_error ("First argument of operator interface at %L must be "
723 "INTENT(IN)", &sym->declared_at);
727 if (args == 2 && i2 != INTENT_IN)
729 gfc_error ("Second argument of operator interface at %L must be "
730 "INTENT(IN)", &sym->declared_at);
735 /* From now on, all we have to do is check that the operator definition
736 doesn't conflict with an intrinsic operator. The rules for this
737 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
738 as well as 12.3.2.1.1 of Fortran 2003:
740 "If the operator is an intrinsic-operator (R310), the number of
741 function arguments shall be consistent with the intrinsic uses of
742 that operator, and the types, kind type parameters, or ranks of the
743 dummy arguments shall differ from those required for the intrinsic
744 operation (7.1.2)." */
746 #define IS_NUMERIC_TYPE(t) \
747 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
749 /* Unary ops are easy, do them first. */
750 if (op == INTRINSIC_NOT)
752 if (t1 == BT_LOGICAL)
758 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
760 if (IS_NUMERIC_TYPE (t1))
766 /* Character intrinsic operators have same character kind, thus
767 operator definitions with operands of different character kinds
769 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
772 /* Intrinsic operators always perform on arguments of same rank,
773 so different ranks is also always safe. (rank == 0) is an exception
774 to that, because all intrinsic operators are elemental. */
775 if (r1 != r2 && r1 != 0 && r2 != 0)
781 case INTRINSIC_EQ_OS:
783 case INTRINSIC_NE_OS:
784 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
789 case INTRINSIC_MINUS:
790 case INTRINSIC_TIMES:
791 case INTRINSIC_DIVIDE:
792 case INTRINSIC_POWER:
793 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
798 case INTRINSIC_GT_OS:
800 case INTRINSIC_GE_OS:
802 case INTRINSIC_LT_OS:
804 case INTRINSIC_LE_OS:
805 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
807 if ((t1 == BT_INTEGER || t1 == BT_REAL)
808 && (t2 == BT_INTEGER || t2 == BT_REAL))
812 case INTRINSIC_CONCAT:
813 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
821 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
831 #undef IS_NUMERIC_TYPE
834 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
840 /* Given a pair of formal argument lists, we see if the two lists can
841 be distinguished by counting the number of nonoptional arguments of
842 a given type/rank in f1 and seeing if there are less then that
843 number of those arguments in f2 (including optional arguments).
844 Since this test is asymmetric, it has to be called twice to make it
845 symmetric. Returns nonzero if the argument lists are incompatible
846 by this test. This subroutine implements rule 1 of section F03:16.2.3.
847 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
850 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
851 const char *p1, const char *p2)
853 int rc, ac1, ac2, i, j, k, n1;
854 gfc_formal_arglist *f;
867 for (f = f1; f; f = f->next)
870 /* Build an array of integers that gives the same integer to
871 arguments of the same type/rank. */
872 arg = XCNEWVEC (arginfo, n1);
875 for (i = 0; i < n1; i++, f = f->next)
883 for (i = 0; i < n1; i++)
885 if (arg[i].flag != -1)
888 if (arg[i].sym && (arg[i].sym->attr.optional
889 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
890 continue; /* Skip OPTIONAL and PASS arguments. */
894 /* Find other non-optional, non-pass arguments of the same type/rank. */
895 for (j = i + 1; j < n1; j++)
896 if ((arg[j].sym == NULL
897 || !(arg[j].sym->attr.optional
898 || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
899 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
900 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
906 /* Now loop over each distinct type found in f1. */
910 for (i = 0; i < n1; i++)
912 if (arg[i].flag != k)
916 for (j = i + 1; j < n1; j++)
917 if (arg[j].flag == k)
920 /* Count the number of non-pass arguments in f2 with that type,
921 including those that are optional. */
924 for (f = f2; f; f = f->next)
925 if ((!p2 || strcmp (f->sym->name, p2) != 0)
926 && (compare_type_rank_if (arg[i].sym, f->sym)
927 || compare_type_rank_if (f->sym, arg[i].sym)))
945 /* Perform the correspondence test in rule (3) of F08:C1215.
946 Returns zero if no argument is found that satisfies this rule,
947 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
950 This test is also not symmetric in f1 and f2 and must be called
951 twice. This test finds problems caused by sorting the actual
952 argument list with keywords. For example:
956 INTEGER :: A ; REAL :: B
960 INTEGER :: A ; REAL :: B
964 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
967 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
968 const char *p1, const char *p2)
970 gfc_formal_arglist *f2_save, *g;
977 if (f1->sym->attr.optional)
980 if (p1 && strcmp (f1->sym->name, p1) == 0)
982 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
985 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
986 || compare_type_rank (f2->sym, f1->sym))
987 && !((gfc_option.allow_std & GFC_STD_F2008)
988 && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
989 || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
992 /* Now search for a disambiguating keyword argument starting at
993 the current non-match. */
994 for (g = f1; g; g = g->next)
996 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
999 sym = find_keyword_arg (g->sym->name, f2_save);
1000 if (sym == NULL || !compare_type_rank (g->sym, sym)
1001 || ((gfc_option.allow_std & GFC_STD_F2008)
1002 && ((sym->attr.allocatable && g->sym->attr.pointer)
1003 || (sym->attr.pointer && g->sym->attr.allocatable))))
1018 /* Check if the characteristics of two dummy arguments match,
1022 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1023 bool type_must_agree, char *errmsg, int err_len)
1025 /* Check type and rank. */
1026 if (type_must_agree && !compare_type_rank (s2, s1))
1028 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1034 if (s1->attr.intent != s2->attr.intent)
1036 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1041 /* Check OPTIONAL attribute. */
1042 if (s1->attr.optional != s2->attr.optional)
1044 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1049 /* Check ALLOCATABLE attribute. */
1050 if (s1->attr.allocatable != s2->attr.allocatable)
1052 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1057 /* Check POINTER attribute. */
1058 if (s1->attr.pointer != s2->attr.pointer)
1060 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1065 /* Check TARGET attribute. */
1066 if (s1->attr.target != s2->attr.target)
1068 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1073 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1074 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1076 /* Check interface of dummy procedures. */
1077 if (s1->attr.flavor == FL_PROCEDURE)
1080 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1083 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
1084 "'%s': %s", s1->name, err);
1089 /* Check string length. */
1090 if (s1->ts.type == BT_CHARACTER
1091 && s1->ts.u.cl && s1->ts.u.cl->length
1092 && s2->ts.u.cl && s2->ts.u.cl->length)
1094 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1095 s2->ts.u.cl->length);
1101 snprintf (errmsg, err_len, "Character length mismatch "
1102 "in argument '%s'", s1->name);
1106 /* FIXME: Implement a warning for this case.
1107 gfc_warning ("Possible character length mismatch in argument '%s'",
1115 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1116 "%i of gfc_dep_compare_expr", compval);
1121 /* Check array shape. */
1122 if (s1->as && s2->as)
1125 gfc_expr *shape1, *shape2;
1127 if (s1->as->type != s2->as->type)
1129 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1134 if (s1->as->type == AS_EXPLICIT)
1135 for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1137 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1138 gfc_copy_expr (s1->as->lower[i]));
1139 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1140 gfc_copy_expr (s2->as->lower[i]));
1141 compval = gfc_dep_compare_expr (shape1, shape2);
1142 gfc_free_expr (shape1);
1143 gfc_free_expr (shape2);
1149 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1150 "argument '%s'", i + 1, s1->name);
1154 /* FIXME: Implement a warning for this case.
1155 gfc_warning ("Possible shape mismatch in argument '%s'",
1163 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1164 "result %i of gfc_dep_compare_expr",
1175 /* Check if the characteristics of two function results match,
1179 check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1180 char *errmsg, int err_len)
1182 gfc_symbol *r1, *r2;
1184 r1 = s1->result ? s1->result : s1;
1185 r2 = s2->result ? s2->result : s2;
1187 if (r1->ts.type == BT_UNKNOWN)
1190 /* Check type and rank. */
1191 if (!compare_type_rank (r1, r2))
1193 snprintf (errmsg, err_len, "Type/rank mismatch in function result");
1197 /* Check ALLOCATABLE attribute. */
1198 if (r1->attr.allocatable != r2->attr.allocatable)
1200 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1205 /* Check POINTER attribute. */
1206 if (r1->attr.pointer != r2->attr.pointer)
1208 snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1213 /* Check CONTIGUOUS attribute. */
1214 if (r1->attr.contiguous != r2->attr.contiguous)
1216 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1221 /* Check PROCEDURE POINTER attribute. */
1222 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1224 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1229 /* Check string length. */
1230 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1232 if (r1->ts.deferred != r2->ts.deferred)
1234 snprintf (errmsg, err_len, "Character length mismatch "
1235 "in function result");
1239 if (r1->ts.u.cl->length)
1241 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1242 r2->ts.u.cl->length);
1248 snprintf (errmsg, err_len, "Character length mismatch "
1249 "in function result");
1253 /* FIXME: Implement a warning for this case.
1254 snprintf (errmsg, err_len, "Possible character length mismatch "
1255 "in function result");*/
1262 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1263 "result %i of gfc_dep_compare_expr", compval);
1269 /* Check array shape. */
1270 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1273 gfc_expr *shape1, *shape2;
1275 if (r1->as->type != r2->as->type)
1277 snprintf (errmsg, err_len, "Shape mismatch in function result");
1281 if (r1->as->type == AS_EXPLICIT)
1282 for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1284 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1285 gfc_copy_expr (r1->as->lower[i]));
1286 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1287 gfc_copy_expr (r2->as->lower[i]));
1288 compval = gfc_dep_compare_expr (shape1, shape2);
1289 gfc_free_expr (shape1);
1290 gfc_free_expr (shape2);
1296 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1297 "function result", i + 1);
1301 /* FIXME: Implement a warning for this case.
1302 gfc_warning ("Possible shape mismatch in return value");*/
1309 gfc_internal_error ("check_result_characteristics (2): "
1310 "Unexpected result %i of "
1311 "gfc_dep_compare_expr", compval);
1321 /* 'Compare' two formal interfaces associated with a pair of symbols.
1322 We return nonzero if there exists an actual argument list that
1323 would be ambiguous between the two interfaces, zero otherwise.
1324 'strict_flag' specifies whether all the characteristics are
1325 required to match, which is not the case for ambiguity checks.
1326 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1329 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1330 int generic_flag, int strict_flag,
1331 char *errmsg, int err_len,
1332 const char *p1, const char *p2)
1334 gfc_formal_arglist *f1, *f2;
1336 gcc_assert (name2 != NULL);
1338 if (s1->attr.function && (s2->attr.subroutine
1339 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1340 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1343 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1347 if (s1->attr.subroutine && s2->attr.function)
1350 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1354 /* Do strict checks on all characteristics
1355 (for dummy procedures and procedure pointer assignments). */
1356 if (!generic_flag && strict_flag)
1358 if (s1->attr.function && s2->attr.function)
1360 /* If both are functions, check result characteristics. */
1361 if (check_result_characteristics (s1, s2, errmsg, err_len)
1366 if (s1->attr.pure && !s2->attr.pure)
1368 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1371 if (s1->attr.elemental && !s2->attr.elemental)
1373 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1378 if (s1->attr.if_source == IFSRC_UNKNOWN
1379 || s2->attr.if_source == IFSRC_UNKNOWN)
1385 if (f1 == NULL && f2 == NULL)
1386 return 1; /* Special case: No arguments. */
1390 if (count_types_test (f1, f2, p1, p2)
1391 || count_types_test (f2, f1, p2, p1))
1393 if (generic_correspondence (f1, f2, p1, p2)
1394 || generic_correspondence (f2, f1, p2, p1))
1398 /* Perform the abbreviated correspondence test for operators (the
1399 arguments cannot be optional and are always ordered correctly).
1400 This is also done when comparing interfaces for dummy procedures and in
1401 procedure pointer assignments. */
1405 /* Check existence. */
1406 if (f1 == NULL && f2 == NULL)
1408 if (f1 == NULL || f2 == NULL)
1411 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1412 "arguments", name2);
1416 if (UNLIMITED_POLY (f1->sym))
1421 /* Check all characteristics. */
1422 if (check_dummy_characteristics (f1->sym, f2->sym,
1423 true, errmsg, err_len) == FAILURE)
1426 else if (!compare_type_rank (f2->sym, f1->sym))
1428 /* Only check type and rank. */
1430 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1443 /* Given a pointer to an interface pointer, remove duplicate
1444 interfaces and make sure that all symbols are either functions
1445 or subroutines, and all of the same kind. Returns nonzero if
1446 something goes wrong. */
1449 check_interface0 (gfc_interface *p, const char *interface_name)
1451 gfc_interface *psave, *q, *qlast;
1454 for (; p; p = p->next)
1456 /* Make sure all symbols in the interface have been defined as
1457 functions or subroutines. */
1458 if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1459 || !p->sym->attr.if_source)
1460 && p->sym->attr.flavor != FL_DERIVED)
1462 if (p->sym->attr.external)
1463 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1464 p->sym->name, interface_name, &p->sym->declared_at);
1466 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1467 "subroutine", p->sym->name, interface_name,
1468 &p->sym->declared_at);
1472 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1473 if ((psave->sym->attr.function && !p->sym->attr.function
1474 && p->sym->attr.flavor != FL_DERIVED)
1475 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1477 if (p->sym->attr.flavor != FL_DERIVED)
1478 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1479 " or all FUNCTIONs", interface_name,
1480 &p->sym->declared_at);
1482 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1483 "generic name is also the name of a derived type",
1484 interface_name, &p->sym->declared_at);
1488 /* F2003, C1207. F2008, C1207. */
1489 if (p->sym->attr.proc == PROC_INTERNAL
1490 && gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1491 "'%s' in %s at %L", p->sym->name, interface_name,
1492 &p->sym->declared_at) == FAILURE)
1497 /* Remove duplicate interfaces in this interface list. */
1498 for (; p; p = p->next)
1502 for (q = p->next; q;)
1504 if (p->sym != q->sym)
1511 /* Duplicate interface. */
1512 qlast->next = q->next;
1523 /* Check lists of interfaces to make sure that no two interfaces are
1524 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1527 check_interface1 (gfc_interface *p, gfc_interface *q0,
1528 int generic_flag, const char *interface_name,
1532 for (; p; p = p->next)
1533 for (q = q0; q; q = q->next)
1535 if (p->sym == q->sym)
1536 continue; /* Duplicates OK here. */
1538 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1541 if (p->sym->attr.flavor != FL_DERIVED
1542 && q->sym->attr.flavor != FL_DERIVED
1543 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1544 generic_flag, 0, NULL, 0, NULL, NULL))
1547 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1548 p->sym->name, q->sym->name, interface_name,
1550 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1551 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1552 p->sym->name, q->sym->name, interface_name,
1555 gfc_warning ("Although not referenced, '%s' has ambiguous "
1556 "interfaces at %L", interface_name, &p->where);
1564 /* Check the generic and operator interfaces of symbols to make sure
1565 that none of the interfaces conflict. The check has to be done
1566 after all of the symbols are actually loaded. */
1569 check_sym_interfaces (gfc_symbol *sym)
1571 char interface_name[100];
1574 if (sym->ns != gfc_current_ns)
1577 if (sym->generic != NULL)
1579 sprintf (interface_name, "generic interface '%s'", sym->name);
1580 if (check_interface0 (sym->generic, interface_name))
1583 for (p = sym->generic; p; p = p->next)
1585 if (p->sym->attr.mod_proc
1586 && (p->sym->attr.if_source != IFSRC_DECL
1587 || p->sym->attr.procedure))
1589 gfc_error ("'%s' at %L is not a module procedure",
1590 p->sym->name, &p->where);
1595 /* Originally, this test was applied to host interfaces too;
1596 this is incorrect since host associated symbols, from any
1597 source, cannot be ambiguous with local symbols. */
1598 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1599 sym->attr.referenced || !sym->attr.use_assoc);
1605 check_uop_interfaces (gfc_user_op *uop)
1607 char interface_name[100];
1611 sprintf (interface_name, "operator interface '%s'", uop->name);
1612 if (check_interface0 (uop->op, interface_name))
1615 for (ns = gfc_current_ns; ns; ns = ns->parent)
1617 uop2 = gfc_find_uop (uop->name, ns);
1621 check_interface1 (uop->op, uop2->op, 0,
1622 interface_name, true);
1626 /* Given an intrinsic op, return an equivalent op if one exists,
1627 or INTRINSIC_NONE otherwise. */
1630 gfc_equivalent_op (gfc_intrinsic_op op)
1635 return INTRINSIC_EQ_OS;
1637 case INTRINSIC_EQ_OS:
1638 return INTRINSIC_EQ;
1641 return INTRINSIC_NE_OS;
1643 case INTRINSIC_NE_OS:
1644 return INTRINSIC_NE;
1647 return INTRINSIC_GT_OS;
1649 case INTRINSIC_GT_OS:
1650 return INTRINSIC_GT;
1653 return INTRINSIC_GE_OS;
1655 case INTRINSIC_GE_OS:
1656 return INTRINSIC_GE;
1659 return INTRINSIC_LT_OS;
1661 case INTRINSIC_LT_OS:
1662 return INTRINSIC_LT;
1665 return INTRINSIC_LE_OS;
1667 case INTRINSIC_LE_OS:
1668 return INTRINSIC_LE;
1671 return INTRINSIC_NONE;
1675 /* For the namespace, check generic, user operator and intrinsic
1676 operator interfaces for consistency and to remove duplicate
1677 interfaces. We traverse the whole namespace, counting on the fact
1678 that most symbols will not have generic or operator interfaces. */
1681 gfc_check_interfaces (gfc_namespace *ns)
1683 gfc_namespace *old_ns, *ns2;
1684 char interface_name[100];
1687 old_ns = gfc_current_ns;
1688 gfc_current_ns = ns;
1690 gfc_traverse_ns (ns, check_sym_interfaces);
1692 gfc_traverse_user_op (ns, check_uop_interfaces);
1694 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1696 if (i == INTRINSIC_USER)
1699 if (i == INTRINSIC_ASSIGN)
1700 strcpy (interface_name, "intrinsic assignment operator");
1702 sprintf (interface_name, "intrinsic '%s' operator",
1703 gfc_op2string ((gfc_intrinsic_op) i));
1705 if (check_interface0 (ns->op[i], interface_name))
1709 gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1712 for (ns2 = ns; ns2; ns2 = ns2->parent)
1714 gfc_intrinsic_op other_op;
1716 if (check_interface1 (ns->op[i], ns2->op[i], 0,
1717 interface_name, true))
1720 /* i should be gfc_intrinsic_op, but has to be int with this cast
1721 here for stupid C++ compatibility rules. */
1722 other_op = gfc_equivalent_op ((gfc_intrinsic_op) i);
1723 if (other_op != INTRINSIC_NONE
1724 && check_interface1 (ns->op[i], ns2->op[other_op],
1725 0, interface_name, true))
1731 gfc_current_ns = old_ns;
1736 symbol_rank (gfc_symbol *sym)
1738 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
1739 return CLASS_DATA (sym)->as->rank;
1741 return (sym->as == NULL) ? 0 : sym->as->rank;
1745 /* Given a symbol of a formal argument list and an expression, if the
1746 formal argument is allocatable, check that the actual argument is
1747 allocatable. Returns nonzero if compatible, zero if not compatible. */
1750 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1752 symbol_attribute attr;
1754 if (formal->attr.allocatable
1755 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
1757 attr = gfc_expr_attr (actual);
1758 if (!attr.allocatable)
1766 /* Given a symbol of a formal argument list and an expression, if the
1767 formal argument is a pointer, see if the actual argument is a
1768 pointer. Returns nonzero if compatible, zero if not compatible. */
1771 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1773 symbol_attribute attr;
1775 if (formal->attr.pointer
1776 || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
1777 && CLASS_DATA (formal)->attr.class_pointer))
1779 attr = gfc_expr_attr (actual);
1781 /* Fortran 2008 allows non-pointer actual arguments. */
1782 if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1793 /* Emit clear error messages for rank mismatch. */
1796 argument_rank_mismatch (const char *name, locus *where,
1797 int rank1, int rank2)
1800 /* TS 29113, C407b. */
1803 gfc_error ("The assumed-rank array at %L requires that the dummy argument"
1804 " '%s' has assumed-rank", where, name);
1806 else if (rank1 == 0)
1808 gfc_error ("Rank mismatch in argument '%s' at %L "
1809 "(scalar and rank-%d)", name, where, rank2);
1811 else if (rank2 == 0)
1813 gfc_error ("Rank mismatch in argument '%s' at %L "
1814 "(rank-%d and scalar)", name, where, rank1);
1818 gfc_error ("Rank mismatch in argument '%s' at %L "
1819 "(rank-%d and rank-%d)", name, where, rank1, rank2);
1824 /* Given a symbol of a formal argument list and an expression, see if
1825 the two are compatible as arguments. Returns nonzero if
1826 compatible, zero if not compatible. */
1829 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1830 int ranks_must_agree, int is_elemental, locus *where)
1833 bool rank_check, is_pointer;
1835 /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1836 procs c_f_pointer or c_f_procpointer, and we need to accept most
1837 pointers the user could give us. This should allow that. */
1838 if (formal->ts.type == BT_VOID)
1841 if (formal->ts.type == BT_DERIVED
1842 && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1843 && actual->ts.type == BT_DERIVED
1844 && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1847 if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1848 /* Make sure the vtab symbol is present when
1849 the module variables are generated. */
1850 gfc_find_derived_vtab (actual->ts.u.derived);
1852 if (actual->ts.type == BT_PROCEDURE)
1855 gfc_symbol *act_sym = actual->symtree->n.sym;
1857 if (formal->attr.flavor != FL_PROCEDURE)
1860 gfc_error ("Invalid procedure argument at %L", &actual->where);
1864 if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1865 sizeof(err), NULL, NULL))
1868 gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1869 formal->name, &actual->where, err);
1873 if (formal->attr.function && !act_sym->attr.function)
1875 gfc_add_function (&act_sym->attr, act_sym->name,
1876 &act_sym->declared_at);
1877 if (act_sym->ts.type == BT_UNKNOWN
1878 && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1881 else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1882 gfc_add_subroutine (&act_sym->attr, act_sym->name,
1883 &act_sym->declared_at);
1889 if (formal->attr.pointer && formal->attr.contiguous
1890 && !gfc_is_simply_contiguous (actual, true))
1893 gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1894 "must be simply contiguous", formal->name, &actual->where);
1898 if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1899 && actual->ts.type != BT_HOLLERITH
1900 && formal->ts.type != BT_ASSUMED
1901 && !gfc_compare_types (&formal->ts, &actual->ts)
1902 && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
1903 && gfc_compare_derived_types (formal->ts.u.derived,
1904 CLASS_DATA (actual)->ts.u.derived)))
1907 gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1908 formal->name, &actual->where, gfc_typename (&actual->ts),
1909 gfc_typename (&formal->ts));
1913 /* F2008, 12.5.2.5; IR F08/0073. */
1914 if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
1915 && ((CLASS_DATA (formal)->attr.class_pointer
1916 && !formal->attr.intent == INTENT_IN)
1917 || CLASS_DATA (formal)->attr.allocatable))
1919 if (actual->ts.type != BT_CLASS)
1922 gfc_error ("Actual argument to '%s' at %L must be polymorphic",
1923 formal->name, &actual->where);
1926 if (!gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
1927 CLASS_DATA (formal)->ts.u.derived))
1930 gfc_error ("Actual argument to '%s' at %L must have the same "
1931 "declared type", formal->name, &actual->where);
1936 /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
1937 is necessary also for F03, so retain error for both.
1938 NOTE: Other type/kind errors pre-empt this error. Since they are F03
1939 compatible, no attempt has been made to channel to this one. */
1940 if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
1941 && (CLASS_DATA (formal)->attr.allocatable
1942 ||CLASS_DATA (formal)->attr.class_pointer))
1945 gfc_error ("Actual argument to '%s' at %L must be unlimited "
1946 "polymorphic since the formal argument is a "
1947 "pointer or allocatable unlimited polymorphic "
1948 "entity [F2008: 12.5.2.5]", formal->name,
1953 if (formal->attr.codimension && !gfc_is_coarray (actual))
1956 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1957 formal->name, &actual->where);
1961 if (formal->attr.codimension && formal->attr.allocatable)
1963 gfc_ref *last = NULL;
1965 for (ref = actual->ref; ref; ref = ref->next)
1966 if (ref->type == REF_COMPONENT)
1969 /* F2008, 12.5.2.6. */
1970 if ((last && last->u.c.component->as->corank != formal->as->corank)
1972 && actual->symtree->n.sym->as->corank != formal->as->corank))
1975 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1976 formal->name, &actual->where, formal->as->corank,
1977 last ? last->u.c.component->as->corank
1978 : actual->symtree->n.sym->as->corank);
1983 if (formal->attr.codimension)
1985 /* F2008, 12.5.2.8. */
1986 if (formal->attr.dimension
1987 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1988 && gfc_expr_attr (actual).dimension
1989 && !gfc_is_simply_contiguous (actual, true))
1992 gfc_error ("Actual argument to '%s' at %L must be simply "
1993 "contiguous", formal->name, &actual->where);
1997 /* F2008, C1303 and C1304. */
1998 if (formal->attr.intent != INTENT_INOUT
1999 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
2000 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2001 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2002 || formal->attr.lock_comp))
2006 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
2007 "which is LOCK_TYPE or has a LOCK_TYPE component",
2008 formal->name, &actual->where);
2013 /* F2008, C1239/C1240. */
2014 if (actual->expr_type == EXPR_VARIABLE
2015 && (actual->symtree->n.sym->attr.asynchronous
2016 || actual->symtree->n.sym->attr.volatile_)
2017 && (formal->attr.asynchronous || formal->attr.volatile_)
2018 && actual->rank && !gfc_is_simply_contiguous (actual, true)
2019 && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
2020 || formal->attr.contiguous))
2023 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
2024 "array without CONTIGUOUS attribute - as actual argument at"
2025 " %L is not simply contiguous and both are ASYNCHRONOUS "
2026 "or VOLATILE", formal->name, &actual->where);
2030 if (formal->attr.allocatable && !formal->attr.codimension
2031 && gfc_expr_attr (actual).codimension)
2033 if (formal->attr.intent == INTENT_OUT)
2036 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2037 "INTENT(OUT) dummy argument '%s'", &actual->where,
2041 else if (gfc_option.warn_surprising && where
2042 && formal->attr.intent != INTENT_IN)
2043 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2044 "argument '%s', which is invalid if the allocation status"
2045 " is modified", &actual->where, formal->name);
2048 /* If the rank is the same or the formal argument has assumed-rank. */
2049 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2052 if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
2053 && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
2056 rank_check = where != NULL && !is_elemental && formal->as
2057 && (formal->as->type == AS_ASSUMED_SHAPE
2058 || formal->as->type == AS_DEFERRED)
2059 && actual->expr_type != EXPR_NULL;
2061 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2062 if (rank_check || ranks_must_agree
2063 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2064 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2065 || (actual->rank == 0
2066 && ((formal->ts.type == BT_CLASS
2067 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2068 || (formal->ts.type != BT_CLASS
2069 && formal->as->type == AS_ASSUMED_SHAPE))
2070 && actual->expr_type != EXPR_NULL)
2071 || (actual->rank == 0 && formal->attr.dimension
2072 && gfc_is_coindexed (actual)))
2075 argument_rank_mismatch (formal->name, &actual->where,
2076 symbol_rank (formal), actual->rank);
2079 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2082 /* At this point, we are considering a scalar passed to an array. This
2083 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2084 - if the actual argument is (a substring of) an element of a
2085 non-assumed-shape/non-pointer/non-polymorphic array; or
2086 - (F2003) if the actual argument is of type character of default/c_char
2089 is_pointer = actual->expr_type == EXPR_VARIABLE
2090 ? actual->symtree->n.sym->attr.pointer : false;
2092 for (ref = actual->ref; ref; ref = ref->next)
2094 if (ref->type == REF_COMPONENT)
2095 is_pointer = ref->u.c.component->attr.pointer;
2096 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2097 && ref->u.ar.dimen > 0
2099 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2103 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2106 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2107 "at %L", formal->name, &actual->where);
2111 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2112 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2115 gfc_error ("Element of assumed-shaped or pointer "
2116 "array passed to array dummy argument '%s' at %L",
2117 formal->name, &actual->where);
2121 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2122 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2124 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2127 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2128 "CHARACTER actual argument with array dummy argument "
2129 "'%s' at %L", formal->name, &actual->where);
2133 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2135 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2136 "array dummy argument '%s' at %L",
2137 formal->name, &actual->where);
2140 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
2146 if (ref == NULL && actual->expr_type != EXPR_NULL)
2149 argument_rank_mismatch (formal->name, &actual->where,
2150 symbol_rank (formal), actual->rank);
2158 /* Returns the storage size of a symbol (formal argument) or
2159 zero if it cannot be determined. */
2161 static unsigned long
2162 get_sym_storage_size (gfc_symbol *sym)
2165 unsigned long strlen, elements;
2167 if (sym->ts.type == BT_CHARACTER)
2169 if (sym->ts.u.cl && sym->ts.u.cl->length
2170 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2171 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2178 if (symbol_rank (sym) == 0)
2182 if (sym->as->type != AS_EXPLICIT)
2184 for (i = 0; i < sym->as->rank; i++)
2186 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2187 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2190 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2191 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2194 return strlen*elements;
2198 /* Returns the storage size of an expression (actual argument) or
2199 zero if it cannot be determined. For an array element, it returns
2200 the remaining size as the element sequence consists of all storage
2201 units of the actual argument up to the end of the array. */
2203 static unsigned long
2204 get_expr_storage_size (gfc_expr *e)
2207 long int strlen, elements;
2208 long int substrlen = 0;
2209 bool is_str_storage = false;
2215 if (e->ts.type == BT_CHARACTER)
2217 if (e->ts.u.cl && e->ts.u.cl->length
2218 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2219 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2220 else if (e->expr_type == EXPR_CONSTANT
2221 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2222 strlen = e->value.character.length;
2227 strlen = 1; /* Length per element. */
2229 if (e->rank == 0 && !e->ref)
2237 for (i = 0; i < e->rank; i++)
2238 elements *= mpz_get_si (e->shape[i]);
2239 return elements*strlen;
2242 for (ref = e->ref; ref; ref = ref->next)
2244 if (ref->type == REF_SUBSTRING && ref->u.ss.start
2245 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2249 /* The string length is the substring length.
2250 Set now to full string length. */
2251 if (!ref->u.ss.length || !ref->u.ss.length->length
2252 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2255 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2257 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2261 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2262 for (i = 0; i < ref->u.ar.dimen; i++)
2264 long int start, end, stride;
2267 if (ref->u.ar.stride[i])
2269 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2270 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2275 if (ref->u.ar.start[i])
2277 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2278 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2282 else if (ref->u.ar.as->lower[i]
2283 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2284 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2288 if (ref->u.ar.end[i])
2290 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2291 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2295 else if (ref->u.ar.as->upper[i]
2296 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2297 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2301 elements *= (end - start)/stride + 1L;
2303 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
2304 for (i = 0; i < ref->u.ar.as->rank; i++)
2306 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2307 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2308 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2309 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2310 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2315 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2316 && e->expr_type == EXPR_VARIABLE)
2318 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2319 || e->symtree->n.sym->attr.pointer)
2325 /* Determine the number of remaining elements in the element
2326 sequence for array element designators. */
2327 is_str_storage = true;
2328 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2330 if (ref->u.ar.start[i] == NULL
2331 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2332 || ref->u.ar.as->upper[i] == NULL
2333 || ref->u.ar.as->lower[i] == NULL
2334 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2335 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2340 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2341 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2343 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2344 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2350 return (is_str_storage) ? substrlen + (elements-1)*strlen
2353 return elements*strlen;
2357 /* Given an expression, check whether it is an array section
2358 which has a vector subscript. If it has, one is returned,
2362 gfc_has_vector_subscript (gfc_expr *e)
2367 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2370 for (ref = e->ref; ref; ref = ref->next)
2371 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2372 for (i = 0; i < ref->u.ar.dimen; i++)
2373 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2380 /* Given formal and actual argument lists, see if they are compatible.
2381 If they are compatible, the actual argument list is sorted to
2382 correspond with the formal list, and elements for missing optional
2383 arguments are inserted. If WHERE pointer is nonnull, then we issue
2384 errors when things don't match instead of just returning the status
2388 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2389 int ranks_must_agree, int is_elemental, locus *where)
2391 gfc_actual_arglist **new_arg, *a, *actual, temp;
2392 gfc_formal_arglist *f;
2394 unsigned long actual_size, formal_size;
2395 bool full_array = false;
2399 if (actual == NULL && formal == NULL)
2403 for (f = formal; f; f = f->next)
2406 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2408 for (i = 0; i < n; i++)
2415 for (a = actual; a; a = a->next, f = f->next)
2417 /* Look for keywords but ignore g77 extensions like %VAL. */
2418 if (a->name != NULL && a->name[0] != '%')
2421 for (f = formal; f; f = f->next, i++)
2425 if (strcmp (f->sym->name, a->name) == 0)
2432 gfc_error ("Keyword argument '%s' at %L is not in "
2433 "the procedure", a->name, &a->expr->where);
2437 if (new_arg[i] != NULL)
2440 gfc_error ("Keyword argument '%s' at %L is already associated "
2441 "with another actual argument", a->name,
2450 gfc_error ("More actual than formal arguments in procedure "
2451 "call at %L", where);
2456 if (f->sym == NULL && a->expr == NULL)
2462 gfc_error ("Missing alternate return spec in subroutine call "
2467 if (a->expr == NULL)
2470 gfc_error ("Unexpected alternate return spec in subroutine "
2471 "call at %L", where);
2475 /* Make sure that intrinsic vtables exist for calls to unlimited
2476 polymorphic formal arguments. */
2477 if (UNLIMITED_POLY(f->sym)
2478 && a->expr->ts.type != BT_DERIVED
2479 && a->expr->ts.type != BT_CLASS)
2480 gfc_find_intrinsic_vtab (&a->expr->ts);
2482 if (a->expr->expr_type == EXPR_NULL
2483 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
2484 && (f->sym->attr.allocatable || !f->sym->attr.optional
2485 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2486 || (f->sym->ts.type == BT_CLASS
2487 && !CLASS_DATA (f->sym)->attr.class_pointer
2488 && (CLASS_DATA (f->sym)->attr.allocatable
2489 || !f->sym->attr.optional
2490 || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
2493 && (!f->sym->attr.optional
2494 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
2495 || (f->sym->ts.type == BT_CLASS
2496 && CLASS_DATA (f->sym)->attr.allocatable)))
2497 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2498 where, f->sym->name);
2500 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2501 "dummy '%s'", where, f->sym->name);
2506 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2507 is_elemental, where))
2510 /* TS 29113, 6.3p2. */
2511 if (f->sym->ts.type == BT_ASSUMED
2512 && (a->expr->ts.type == BT_DERIVED
2513 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2515 gfc_namespace *f2k_derived;
2517 f2k_derived = a->expr->ts.type == BT_DERIVED
2518 ? a->expr->ts.u.derived->f2k_derived
2519 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2522 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
2524 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2525 "derived type with type-bound or FINAL procedures",
2531 /* Special case for character arguments. For allocatable, pointer
2532 and assumed-shape dummies, the string length needs to match
2534 if (a->expr->ts.type == BT_CHARACTER
2535 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2536 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2537 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2538 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2539 && (f->sym->attr.pointer || f->sym->attr.allocatable
2540 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2541 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2542 f->sym->ts.u.cl->length->value.integer) != 0))
2544 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2545 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2546 "argument and pointer or allocatable dummy argument "
2548 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2549 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2550 f->sym->name, &a->expr->where);
2552 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2553 "argument and assumed-shape dummy argument '%s' "
2555 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2556 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2557 f->sym->name, &a->expr->where);
2561 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2562 && f->sym->ts.deferred != a->expr->ts.deferred
2563 && a->expr->ts.type == BT_CHARACTER)
2566 gfc_error ("Actual argument at %L to allocatable or "
2567 "pointer dummy argument '%s' must have a deferred "
2568 "length type parameter if and only if the dummy has one",
2569 &a->expr->where, f->sym->name);
2573 if (f->sym->ts.type == BT_CLASS)
2574 goto skip_size_check;
2576 actual_size = get_expr_storage_size (a->expr);
2577 formal_size = get_sym_storage_size (f->sym);
2578 if (actual_size != 0 && actual_size < formal_size
2579 && a->expr->ts.type != BT_PROCEDURE
2580 && f->sym->attr.flavor != FL_PROCEDURE)
2582 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2583 gfc_warning ("Character length of actual argument shorter "
2584 "than of dummy argument '%s' (%lu/%lu) at %L",
2585 f->sym->name, actual_size, formal_size,
2588 gfc_warning ("Actual argument contains too few "
2589 "elements for dummy argument '%s' (%lu/%lu) at %L",
2590 f->sym->name, actual_size, formal_size,
2597 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2598 argument is provided for a procedure pointer formal argument. */
2599 if (f->sym->attr.proc_pointer
2600 && !((a->expr->expr_type == EXPR_VARIABLE
2601 && a->expr->symtree->n.sym->attr.proc_pointer)
2602 || (a->expr->expr_type == EXPR_FUNCTION
2603 && a->expr->symtree->n.sym->result->attr.proc_pointer)
2604 || gfc_is_proc_ptr_comp (a->expr)))
2607 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2608 f->sym->name, &a->expr->where);
2612 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2613 provided for a procedure formal argument. */
2614 if (f->sym->attr.flavor == FL_PROCEDURE
2615 && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
2618 gfc_error ("Expected a procedure for argument '%s' at %L",
2619 f->sym->name, &a->expr->where);
2623 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2624 && a->expr->expr_type == EXPR_VARIABLE
2625 && a->expr->symtree->n.sym->as
2626 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2627 && (a->expr->ref == NULL
2628 || (a->expr->ref->type == REF_ARRAY
2629 && a->expr->ref->u.ar.type == AR_FULL)))
2632 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2633 " array at %L", f->sym->name, where);
2637 if (a->expr->expr_type != EXPR_NULL
2638 && compare_pointer (f->sym, a->expr) == 0)
2641 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2642 f->sym->name, &a->expr->where);
2646 if (a->expr->expr_type != EXPR_NULL
2647 && (gfc_option.allow_std & GFC_STD_F2008) == 0
2648 && compare_pointer (f->sym, a->expr) == 2)
2651 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2652 "pointer dummy '%s'", &a->expr->where,f->sym->name);
2657 /* Fortran 2008, C1242. */
2658 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2661 gfc_error ("Coindexed actual argument at %L to pointer "
2663 &a->expr->where, f->sym->name);
2667 /* Fortran 2008, 12.5.2.5 (no constraint). */
2668 if (a->expr->expr_type == EXPR_VARIABLE
2669 && f->sym->attr.intent != INTENT_IN
2670 && f->sym->attr.allocatable
2671 && gfc_is_coindexed (a->expr))
2674 gfc_error ("Coindexed actual argument at %L to allocatable "
2675 "dummy '%s' requires INTENT(IN)",
2676 &a->expr->where, f->sym->name);
2680 /* Fortran 2008, C1237. */
2681 if (a->expr->expr_type == EXPR_VARIABLE
2682 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2683 && gfc_is_coindexed (a->expr)
2684 && (a->expr->symtree->n.sym->attr.volatile_
2685 || a->expr->symtree->n.sym->attr.asynchronous))
2688 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2689 "%L requires that dummy '%s' has neither "
2690 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2695 /* Fortran 2008, 12.5.2.4 (no constraint). */
2696 if (a->expr->expr_type == EXPR_VARIABLE
2697 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2698 && gfc_is_coindexed (a->expr)
2699 && gfc_has_ultimate_allocatable (a->expr))
2702 gfc_error ("Coindexed actual argument at %L with allocatable "
2703 "ultimate component to dummy '%s' requires either VALUE "
2704 "or INTENT(IN)", &a->expr->where, f->sym->name);
2708 if (f->sym->ts.type == BT_CLASS
2709 && CLASS_DATA (f->sym)->attr.allocatable
2710 && gfc_is_class_array_ref (a->expr, &full_array)
2714 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2715 "array at %L", f->sym->name, &a->expr->where);
2720 if (a->expr->expr_type != EXPR_NULL
2721 && compare_allocatable (f->sym, a->expr) == 0)
2724 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2725 f->sym->name, &a->expr->where);
2729 /* Check intent = OUT/INOUT for definable actual argument. */
2730 if ((f->sym->attr.intent == INTENT_OUT
2731 || f->sym->attr.intent == INTENT_INOUT))
2733 const char* context = (where
2734 ? _("actual argument to INTENT = OUT/INOUT")
2737 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2738 && CLASS_DATA (f->sym)->attr.class_pointer)
2739 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2740 && gfc_check_vardef_context (a->expr, true, false, false, context)
2743 if (gfc_check_vardef_context (a->expr, false, false, false, context)
2748 if ((f->sym->attr.intent == INTENT_OUT
2749 || f->sym->attr.intent == INTENT_INOUT
2750 || f->sym->attr.volatile_
2751 || f->sym->attr.asynchronous)
2752 && gfc_has_vector_subscript (a->expr))
2755 gfc_error ("Array-section actual argument with vector "
2756 "subscripts at %L is incompatible with INTENT(OUT), "
2757 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2758 "of the dummy argument '%s'",
2759 &a->expr->where, f->sym->name);
2763 /* C1232 (R1221) For an actual argument which is an array section or
2764 an assumed-shape array, the dummy argument shall be an assumed-
2765 shape array, if the dummy argument has the VOLATILE attribute. */
2767 if (f->sym->attr.volatile_
2768 && a->expr->symtree->n.sym->as
2769 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2770 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2773 gfc_error ("Assumed-shape actual argument at %L is "
2774 "incompatible with the non-assumed-shape "
2775 "dummy argument '%s' due to VOLATILE attribute",
2776 &a->expr->where,f->sym->name);
2780 if (f->sym->attr.volatile_
2781 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2782 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2785 gfc_error ("Array-section actual argument at %L is "
2786 "incompatible with the non-assumed-shape "
2787 "dummy argument '%s' due to VOLATILE attribute",
2788 &a->expr->where,f->sym->name);
2792 /* C1233 (R1221) For an actual argument which is a pointer array, the
2793 dummy argument shall be an assumed-shape or pointer array, if the
2794 dummy argument has the VOLATILE attribute. */
2796 if (f->sym->attr.volatile_
2797 && a->expr->symtree->n.sym->attr.pointer
2798 && a->expr->symtree->n.sym->as
2800 && (f->sym->as->type == AS_ASSUMED_SHAPE
2801 || f->sym->attr.pointer)))
2804 gfc_error ("Pointer-array actual argument at %L requires "
2805 "an assumed-shape or pointer-array dummy "
2806 "argument '%s' due to VOLATILE attribute",
2807 &a->expr->where,f->sym->name);
2818 /* Make sure missing actual arguments are optional. */
2820 for (f = formal; f; f = f->next, i++)
2822 if (new_arg[i] != NULL)
2827 gfc_error ("Missing alternate return spec in subroutine call "
2831 if (!f->sym->attr.optional)
2834 gfc_error ("Missing actual argument for argument '%s' at %L",
2835 f->sym->name, where);
2840 /* The argument lists are compatible. We now relink a new actual
2841 argument list with null arguments in the right places. The head
2842 of the list remains the head. */
2843 for (i = 0; i < n; i++)
2844 if (new_arg[i] == NULL)
2845 new_arg[i] = gfc_get_actual_arglist ();
2850 *new_arg[0] = *actual;
2854 new_arg[0] = new_arg[na];
2858 for (i = 0; i < n - 1; i++)
2859 new_arg[i]->next = new_arg[i + 1];
2861 new_arg[i]->next = NULL;
2863 if (*ap == NULL && n > 0)
2866 /* Note the types of omitted optional arguments. */
2867 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2868 if (a->expr == NULL && a->label == NULL)
2869 a->missing_arg_type = f->sym->ts.type;
2877 gfc_formal_arglist *f;
2878 gfc_actual_arglist *a;
2882 /* qsort comparison function for argument pairs, with the following
2884 - p->a->expr == NULL
2885 - p->a->expr->expr_type != EXPR_VARIABLE
2886 - growing p->a->expr->symbol. */
2889 pair_cmp (const void *p1, const void *p2)
2891 const gfc_actual_arglist *a1, *a2;
2893 /* *p1 and *p2 are elements of the to-be-sorted array. */
2894 a1 = ((const argpair *) p1)->a;
2895 a2 = ((const argpair *) p2)->a;
2904 if (a1->expr->expr_type != EXPR_VARIABLE)
2906 if (a2->expr->expr_type != EXPR_VARIABLE)
2910 if (a2->expr->expr_type != EXPR_VARIABLE)
2912 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2916 /* Given two expressions from some actual arguments, test whether they
2917 refer to the same expression. The analysis is conservative.
2918 Returning FAILURE will produce no warning. */
2921 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2923 const gfc_ref *r1, *r2;
2926 || e1->expr_type != EXPR_VARIABLE
2927 || e2->expr_type != EXPR_VARIABLE
2928 || e1->symtree->n.sym != e2->symtree->n.sym)
2931 /* TODO: improve comparison, see expr.c:show_ref(). */
2932 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2934 if (r1->type != r2->type)
2939 if (r1->u.ar.type != r2->u.ar.type)
2941 /* TODO: At the moment, consider only full arrays;
2942 we could do better. */
2943 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2948 if (r1->u.c.component != r2->u.c.component)
2956 gfc_internal_error ("compare_actual_expr(): Bad component code");
2965 /* Given formal and actual argument lists that correspond to one
2966 another, check that identical actual arguments aren't not
2967 associated with some incompatible INTENTs. */
2970 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2972 sym_intent f1_intent, f2_intent;
2973 gfc_formal_arglist *f1;
2974 gfc_actual_arglist *a1;
2977 gfc_try t = SUCCESS;
2980 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2982 if (f1 == NULL && a1 == NULL)
2984 if (f1 == NULL || a1 == NULL)
2985 gfc_internal_error ("check_some_aliasing(): List mismatch");
2990 p = XALLOCAVEC (argpair, n);
2992 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2998 qsort (p, n, sizeof (argpair), pair_cmp);
3000 for (i = 0; i < n; i++)
3003 || p[i].a->expr->expr_type != EXPR_VARIABLE
3004 || p[i].a->expr->ts.type == BT_PROCEDURE)
3006 f1_intent = p[i].f->sym->attr.intent;
3007 for (j = i + 1; j < n; j++)
3009 /* Expected order after the sort. */
3010 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
3011 gfc_internal_error ("check_some_aliasing(): corrupted data");
3013 /* Are the expression the same? */
3014 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
3016 f2_intent = p[j].f->sym->attr.intent;
3017 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
3018 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
3020 gfc_warning ("Same actual argument associated with INTENT(%s) "
3021 "argument '%s' and INTENT(%s) argument '%s' at %L",
3022 gfc_intent_string (f1_intent), p[i].f->sym->name,
3023 gfc_intent_string (f2_intent), p[j].f->sym->name,
3024 &p[i].a->expr->where);
3034 /* Given formal and actual argument lists that correspond to one
3035 another, check that they are compatible in the sense that intents
3036 are not mismatched. */
3039 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
3041 sym_intent f_intent;
3043 for (;; f = f->next, a = a->next)
3045 if (f == NULL && a == NULL)
3047 if (f == NULL || a == NULL)
3048 gfc_internal_error ("check_intents(): List mismatch");
3050 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
3053 f_intent = f->sym->attr.intent;
3055 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
3057 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3058 && CLASS_DATA (f->sym)->attr.class_pointer)
3059 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3061 gfc_error ("Procedure argument at %L is local to a PURE "
3062 "procedure and has the POINTER attribute",
3068 /* Fortran 2008, C1283. */
3069 if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
3071 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
3073 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3074 "is passed to an INTENT(%s) argument",
3075 &a->expr->where, gfc_intent_string (f_intent));
3079 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3080 && CLASS_DATA (f->sym)->attr.class_pointer)
3081 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3083 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3084 "is passed to a POINTER dummy argument",
3090 /* F2008, Section 12.5.2.4. */
3091 if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3092 && gfc_is_coindexed (a->expr))
3094 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3095 "polymorphic dummy argument '%s'",
3096 &a->expr->where, f->sym->name);
3105 /* Check how a procedure is used against its interface. If all goes
3106 well, the actual argument list will also end up being properly
3110 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3112 /* Warn about calls with an implicit interface. Special case
3113 for calling a ISO_C_BINDING becase c_loc and c_funloc
3114 are pseudo-unknown. Additionally, warn about procedures not
3115 explicitly declared at all if requested. */
3116 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
3118 if (gfc_option.warn_implicit_interface)
3119 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3121 else if (gfc_option.warn_implicit_procedure
3122 && sym->attr.proc == PROC_UNKNOWN)
3123 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3127 if (sym->attr.if_source == IFSRC_UNKNOWN)
3129 gfc_actual_arglist *a;
3131 if (sym->attr.pointer)
3133 gfc_error("The pointer object '%s' at %L must have an explicit "
3134 "function interface or be declared as array",
3139 if (sym->attr.allocatable && !sym->attr.external)
3141 gfc_error("The allocatable object '%s' at %L must have an explicit "
3142 "function interface or be declared as array",
3147 if (sym->attr.allocatable)
3149 gfc_error("Allocatable function '%s' at %L must have an explicit "
3150 "function interface", sym->name, where);
3154 for (a = *ap; a; a = a->next)
3156 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3157 if (a->name != NULL && a->name[0] != '%')
3159 gfc_error("Keyword argument requires explicit interface "
3160 "for procedure '%s' at %L", sym->name, &a->expr->where);
3164 /* TS 29113, 6.2. */
3165 if (a->expr && a->expr->ts.type == BT_ASSUMED
3166 && sym->intmod_sym_id != ISOCBINDING_LOC)
3168 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3169 "interface", a->expr->symtree->n.sym->name,
3174 /* F2008, C1303 and C1304. */
3176 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3177 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3178 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3179 || gfc_expr_attr (a->expr).lock_comp))
3181 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3182 "component at %L requires an explicit interface for "
3183 "procedure '%s'", &a->expr->where, sym->name);
3187 if (a->expr && a->expr->expr_type == EXPR_NULL
3188 && a->expr->ts.type == BT_UNKNOWN)
3190 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3194 /* TS 29113, C407b. */
3195 if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3196 && symbol_rank (a->expr->symtree->n.sym) == -1)
3198 gfc_error ("Assumed-rank argument requires an explicit interface "
3199 "at %L", &a->expr->where);
3207 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
3210 if (check_intents (sym->formal, *ap) == FAILURE)
3213 if (gfc_option.warn_aliasing)
3214 check_some_aliasing (sym->formal, *ap);
3220 /* Check how a procedure pointer component is used against its interface.
3221 If all goes well, the actual argument list will also end up being properly
3222 sorted. Completely analogous to gfc_procedure_use. */
3225 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3228 /* Warn about calls with an implicit interface. Special case
3229 for calling a ISO_C_BINDING becase c_loc and c_funloc
3230 are pseudo-unknown. */
3231 if (gfc_option.warn_implicit_interface
3232 && comp->attr.if_source == IFSRC_UNKNOWN
3233 && !comp->attr.is_iso_c)
3234 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3235 "interface at %L", comp->name, where);
3237 if (comp->attr.if_source == IFSRC_UNKNOWN)
3239 gfc_actual_arglist *a;
3240 for (a = *ap; a; a = a->next)
3242 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3243 if (a->name != NULL && a->name[0] != '%')
3245 gfc_error("Keyword argument requires explicit interface "
3246 "for procedure pointer component '%s' at %L",
3247 comp->name, &a->expr->where);
3255 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
3258 check_intents (comp->formal, *ap);
3259 if (gfc_option.warn_aliasing)
3260 check_some_aliasing (comp->formal, *ap);
3264 /* Try if an actual argument list matches the formal list of a symbol,
3265 respecting the symbol's attributes like ELEMENTAL. This is used for
3266 GENERIC resolution. */
3269 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3273 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
3275 r = !sym->attr.elemental;
3276 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
3278 check_intents (sym->formal, *args);
3279 if (gfc_option.warn_aliasing)
3280 check_some_aliasing (sym->formal, *args);
3288 /* Given an interface pointer and an actual argument list, search for
3289 a formal argument list that matches the actual. If found, returns
3290 a pointer to the symbol of the correct interface. Returns NULL if
3294 gfc_search_interface (gfc_interface *intr, int sub_flag,
3295 gfc_actual_arglist **ap)
3297 gfc_symbol *elem_sym = NULL;
3298 gfc_symbol *null_sym = NULL;
3299 locus null_expr_loc;
3300 gfc_actual_arglist *a;
3301 bool has_null_arg = false;
3303 for (a = *ap; a; a = a->next)
3304 if (a->expr && a->expr->expr_type == EXPR_NULL
3305 && a->expr->ts.type == BT_UNKNOWN)
3307 has_null_arg = true;
3308 null_expr_loc = a->expr->where;
3312 for (; intr; intr = intr->next)
3314 if (intr->sym->attr.flavor == FL_DERIVED)
3316 if (sub_flag && intr->sym->attr.function)
3318 if (!sub_flag && intr->sym->attr.subroutine)
3321 if (gfc_arglist_matches_symbol (ap, intr->sym))
3323 if (has_null_arg && null_sym)
3325 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3326 "between specific functions %s and %s",
3327 &null_expr_loc, null_sym->name, intr->sym->name);
3330 else if (has_null_arg)
3332 null_sym = intr->sym;
3336 /* Satisfy 12.4.4.1 such that an elemental match has lower
3337 weight than a non-elemental match. */
3338 if (intr->sym->attr.elemental)
3340 elem_sym = intr->sym;
3350 return elem_sym ? elem_sym : NULL;
3354 /* Do a brute force recursive search for a symbol. */
3356 static gfc_symtree *
3357 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3361 if (root->n.sym == sym)
3366 st = find_symtree0 (root->left, sym);
3367 if (root->right && ! st)
3368 st = find_symtree0 (root->right, sym);
3373 /* Find a symtree for a symbol. */
3376 gfc_find_sym_in_symtree (gfc_symbol *sym)
3381 /* First try to find it by name. */
3382 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3383 if (st && st->n.sym == sym)
3386 /* If it's been renamed, resort to a brute-force search. */
3387 /* TODO: avoid having to do this search. If the symbol doesn't exist
3388 in the symtree for the current namespace, it should probably be added. */
3389 for (ns = gfc_current_ns; ns; ns = ns->parent)
3391 st = find_symtree0 (ns->sym_root, sym);
3395 gfc_internal_error ("Unable to find symbol %s", sym->name);
3400 /* See if the arglist to an operator-call contains a derived-type argument
3401 with a matching type-bound operator. If so, return the matching specific
3402 procedure defined as operator-target as well as the base-object to use
3403 (which is the found derived-type argument with operator). The generic
3404 name, if any, is transmitted to the final expression via 'gname'. */
3406 static gfc_typebound_proc*
3407 matching_typebound_op (gfc_expr** tb_base,
3408 gfc_actual_arglist* args,
3409 gfc_intrinsic_op op, const char* uop,
3410 const char ** gname)
3412 gfc_actual_arglist* base;
3414 for (base = args; base; base = base->next)
3415 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3417 gfc_typebound_proc* tb;
3418 gfc_symbol* derived;
3421 while (base->expr->expr_type == EXPR_OP
3422 && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3423 base->expr = base->expr->value.op.op1;
3425 if (base->expr->ts.type == BT_CLASS)
3427 if (CLASS_DATA (base->expr) == NULL
3428 || !gfc_expr_attr (base->expr).class_ok)
3430 derived = CLASS_DATA (base->expr)->ts.u.derived;
3433 derived = base->expr->ts.u.derived;
3435 if (op == INTRINSIC_USER)
3437 gfc_symtree* tb_uop;
3440 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3449 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3452 /* This means we hit a PRIVATE operator which is use-associated and
3453 should thus not be seen. */
3454 if (result == FAILURE)
3457 /* Look through the super-type hierarchy for a matching specific
3459 for (; tb; tb = tb->overridden)
3463 gcc_assert (tb->is_generic);
3464 for (g = tb->u.generic; g; g = g->next)
3467 gfc_actual_arglist* argcopy;
3470 gcc_assert (g->specific);
3471 if (g->specific->error)
3474 target = g->specific->u.specific->n.sym;
3476 /* Check if this arglist matches the formal. */
3477 argcopy = gfc_copy_actual_arglist (args);
3478 matches = gfc_arglist_matches_symbol (&argcopy, target);
3479 gfc_free_actual_arglist (argcopy);
3481 /* Return if we found a match. */
3484 *tb_base = base->expr;
3485 *gname = g->specific_st->name;
3496 /* For the 'actual arglist' of an operator call and a specific typebound
3497 procedure that has been found the target of a type-bound operator, build the
3498 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3499 type-bound procedures rather than resolving type-bound operators 'directly'
3500 so that we can reuse the existing logic. */
3503 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3504 gfc_expr* base, gfc_typebound_proc* target,
3507 e->expr_type = EXPR_COMPCALL;
3508 e->value.compcall.tbp = target;
3509 e->value.compcall.name = gname ? gname : "$op";
3510 e->value.compcall.actual = actual;
3511 e->value.compcall.base_object = base;
3512 e->value.compcall.ignore_pass = 1;
3513 e->value.compcall.assign = 0;
3514 if (e->ts.type == BT_UNKNOWN
3515 && target->function)
3517 if (target->is_generic)
3518 e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3520 e->ts = target->u.specific->n.sym->ts;
3525 /* This subroutine is called when an expression is being resolved.
3526 The expression node in question is either a user defined operator
3527 or an intrinsic operator with arguments that aren't compatible
3528 with the operator. This subroutine builds an actual argument list
3529 corresponding to the operands, then searches for a compatible
3530 interface. If one is found, the expression node is replaced with
3531 the appropriate function call. We use the 'match' enum to specify
3532 whether a replacement has been made or not, or if an error occurred. */
3535 gfc_extend_expr (gfc_expr *e)
3537 gfc_actual_arglist *actual;
3546 actual = gfc_get_actual_arglist ();
3547 actual->expr = e->value.op.op1;
3551 if (e->value.op.op2 != NULL)
3553 actual->next = gfc_get_actual_arglist ();
3554 actual->next->expr = e->value.op.op2;
3557 i = fold_unary_intrinsic (e->value.op.op);
3559 if (i == INTRINSIC_USER)
3561 for (ns = gfc_current_ns; ns; ns = ns->parent)
3563 uop = gfc_find_uop (e->value.op.uop->name, ns);
3567 sym = gfc_search_interface (uop->op, 0, &actual);
3574 for (ns = gfc_current_ns; ns; ns = ns->parent)
3576 /* Due to the distinction between '==' and '.eq.' and friends, one has
3577 to check if either is defined. */
3580 #define CHECK_OS_COMPARISON(comp) \
3581 case INTRINSIC_##comp: \
3582 case INTRINSIC_##comp##_OS: \
3583 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3585 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3587 CHECK_OS_COMPARISON(EQ)
3588 CHECK_OS_COMPARISON(NE)
3589 CHECK_OS_COMPARISON(GT)
3590 CHECK_OS_COMPARISON(GE)
3591 CHECK_OS_COMPARISON(LT)
3592 CHECK_OS_COMPARISON(LE)
3593 #undef CHECK_OS_COMPARISON
3596 sym = gfc_search_interface (ns->op[i], 0, &actual);
3604 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3605 found rather than just taking the first one and not checking further. */
3609 gfc_typebound_proc* tbo;
3612 /* See if we find a matching type-bound operator. */
3613 if (i == INTRINSIC_USER)
3614 tbo = matching_typebound_op (&tb_base, actual,
3615 i, e->value.op.uop->name, &gname);
3619 #define CHECK_OS_COMPARISON(comp) \
3620 case INTRINSIC_##comp: \
3621 case INTRINSIC_##comp##_OS: \
3622 tbo = matching_typebound_op (&tb_base, actual, \
3623 INTRINSIC_##comp, NULL, &gname); \
3625 tbo = matching_typebound_op (&tb_base, actual, \
3626 INTRINSIC_##comp##_OS, NULL, &gname); \
3628 CHECK_OS_COMPARISON(EQ)
3629 CHECK_OS_COMPARISON(NE)
3630 CHECK_OS_COMPARISON(GT)
3631 CHECK_OS_COMPARISON(GE)
3632 CHECK_OS_COMPARISON(LT)
3633 CHECK_OS_COMPARISON(LE)
3634 #undef CHECK_OS_COMPARISON
3637 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3641 /* If there is a matching typebound-operator, replace the expression with
3642 a call to it and succeed. */
3647 gcc_assert (tb_base);
3648 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3650 result = gfc_resolve_expr (e);
3651 if (result == FAILURE)
3657 /* Don't use gfc_free_actual_arglist(). */
3658 free (actual->next);
3664 /* Change the expression node to a function call. */
3665 e->expr_type = EXPR_FUNCTION;
3666 e->symtree = gfc_find_sym_in_symtree (sym);
3667 e->value.function.actual = actual;
3668 e->value.function.esym = NULL;
3669 e->value.function.isym = NULL;
3670 e->value.function.name = NULL;
3671 e->user_operator = 1;
3673 if (gfc_resolve_expr (e) == FAILURE)
3680 /* Tries to replace an assignment code node with a subroutine call to
3681 the subroutine associated with the assignment operator. Return
3682 SUCCESS if the node was replaced. On FAILURE, no error is
3686 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3688 gfc_actual_arglist *actual;
3689 gfc_expr *lhs, *rhs;
3698 /* Don't allow an intrinsic assignment to be replaced. */
3699 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3700 && (rhs->rank == 0 || rhs->rank == lhs->rank)
3701 && (lhs->ts.type == rhs->ts.type
3702 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3705 actual = gfc_get_actual_arglist ();
3708 actual->next = gfc_get_actual_arglist ();
3709 actual->next->expr = rhs;
3713 for (; ns; ns = ns->parent)
3715 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3720 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3724 gfc_typebound_proc* tbo;
3727 /* See if we find a matching type-bound assignment. */
3728 tbo = matching_typebound_op (&tb_base, actual,
3729 INTRINSIC_ASSIGN, NULL, &gname);
3731 /* If there is one, replace the expression with a call to it and
3735 gcc_assert (tb_base);
3736 c->expr1 = gfc_get_expr ();
3737 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3738 c->expr1->value.compcall.assign = 1;
3739 c->expr1->where = c->loc;
3741 c->op = EXEC_COMPCALL;
3743 /* c is resolved from the caller, so no need to do it here. */
3748 free (actual->next);
3753 /* Replace the assignment with the call. */
3754 c->op = EXEC_ASSIGN_CALL;
3755 c->symtree = gfc_find_sym_in_symtree (sym);
3758 c->ext.actual = actual;
3764 /* Make sure that the interface just parsed is not already present in
3765 the given interface list. Ambiguity isn't checked yet since module
3766 procedures can be present without interfaces. */
3769 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
3773 for (ip = base; ip; ip = ip->next)
3775 if (ip->sym == new_sym)
3777 gfc_error ("Entity '%s' at %L is already present in the interface",
3778 new_sym->name, &loc);
3787 /* Add a symbol to the current interface. */
3790 gfc_add_interface (gfc_symbol *new_sym)
3792 gfc_interface **head, *intr;
3796 switch (current_interface.type)
3798 case INTERFACE_NAMELESS:
3799 case INTERFACE_ABSTRACT:
3802 case INTERFACE_INTRINSIC_OP:
3803 for (ns = current_interface.ns; ns; ns = ns->parent)
3804 switch (current_interface.op)
3807 case INTRINSIC_EQ_OS:
3808 if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
3809 gfc_current_locus) == FAILURE
3810 || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
3811 gfc_current_locus) == FAILURE)
3816 case INTRINSIC_NE_OS:
3817 if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
3818 gfc_current_locus) == FAILURE
3819 || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
3820 gfc_current_locus) == FAILURE)
3825 case INTRINSIC_GT_OS:
3826 if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
3827 gfc_current_locus) == FAILURE
3828 || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
3829 gfc_current_locus) == FAILURE)
3834 case INTRINSIC_GE_OS:
3835 if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
3836 gfc_current_locus) == FAILURE
3837 || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
3838 gfc_current_locus) == FAILURE)
3843 case INTRINSIC_LT_OS:
3844 if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
3845 gfc_current_locus) == FAILURE
3846 || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
3847 gfc_current_locus) == FAILURE)
3852 case INTRINSIC_LE_OS:
3853 if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
3854 gfc_current_locus) == FAILURE
3855 || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
3856 gfc_current_locus) == FAILURE)
3861 if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
3862 gfc_current_locus) == FAILURE)
3866 head = ¤t_interface.ns->op[current_interface.op];
3869 case INTERFACE_GENERIC:
3870 for (ns = current_interface.ns; ns; ns = ns->parent)
3872 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3876 if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
3881 head = ¤t_interface.sym->generic;
3884 case INTERFACE_USER_OP:
3885 if (gfc_check_new_interface (current_interface.uop->op, new_sym,
3886 gfc_current_locus) == FAILURE)
3889 head = ¤t_interface.uop->op;
3893 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3896 intr = gfc_get_interface ();
3897 intr->sym = new_sym;
3898 intr->where = gfc_current_locus;
3908 gfc_current_interface_head (void)
3910 switch (current_interface.type)
3912 case INTERFACE_INTRINSIC_OP:
3913 return current_interface.ns->op[current_interface.op];
3916 case INTERFACE_GENERIC:
3917 return current_interface.sym->generic;
3920 case INTERFACE_USER_OP:
3921 return current_interface.uop->op;
3931 gfc_set_current_interface_head (gfc_interface *i)
3933 switch (current_interface.type)
3935 case INTERFACE_INTRINSIC_OP:
3936 current_interface.ns->op[current_interface.op] = i;
3939 case INTERFACE_GENERIC:
3940 current_interface.sym->generic = i;
3943 case INTERFACE_USER_OP:
3944 current_interface.uop->op = i;
3953 /* Gets rid of a formal argument list. We do not free symbols.
3954 Symbols are freed when a namespace is freed. */
3957 gfc_free_formal_arglist (gfc_formal_arglist *p)
3959 gfc_formal_arglist *q;
3969 /* Check that it is ok for the type-bound procedure 'proc' to override the
3970 procedure 'old', cf. F08:4.5.7.3. */
3973 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3976 gfc_symbol *proc_target, *old_target;
3977 unsigned proc_pass_arg, old_pass_arg, argpos;
3978 gfc_formal_arglist *proc_formal, *old_formal;
3982 /* This procedure should only be called for non-GENERIC proc. */
3983 gcc_assert (!proc->n.tb->is_generic);
3985 /* If the overwritten procedure is GENERIC, this is an error. */
3986 if (old->n.tb->is_generic)
3988 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3989 old->name, &proc->n.tb->where);
3993 where = proc->n.tb->where;
3994 proc_target = proc->n.tb->u.specific->n.sym;
3995 old_target = old->n.tb->u.specific->n.sym;
3997 /* Check that overridden binding is not NON_OVERRIDABLE. */
3998 if (old->n.tb->non_overridable)
4000 gfc_error ("'%s' at %L overrides a procedure binding declared"
4001 " NON_OVERRIDABLE", proc->name, &where);
4005 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
4006 if (!old->n.tb->deferred && proc->n.tb->deferred)
4008 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
4009 " non-DEFERRED binding", proc->name, &where);
4013 /* If the overridden binding is PURE, the overriding must be, too. */
4014 if (old_target->attr.pure && !proc_target->attr.pure)
4016 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
4017 proc->name, &where);
4021 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
4022 is not, the overriding must not be either. */
4023 if (old_target->attr.elemental && !proc_target->attr.elemental)
4025 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4026 " ELEMENTAL", proc->name, &where);
4029 if (!old_target->attr.elemental && proc_target->attr.elemental)
4031 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4032 " be ELEMENTAL, either", proc->name, &where);
4036 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4038 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4040 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4041 " SUBROUTINE", proc->name, &where);
4045 /* If the overridden binding is a FUNCTION, the overriding must also be a
4046 FUNCTION and have the same characteristics. */
4047 if (old_target->attr.function)
4049 if (!proc_target->attr.function)
4051 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4052 " FUNCTION", proc->name, &where);
4056 if (check_result_characteristics (proc_target, old_target,
4057 err, sizeof(err)) == FAILURE)
4059 gfc_error ("Result mismatch for the overriding procedure "
4060 "'%s' at %L: %s", proc->name, &where, err);
4065 /* If the overridden binding is PUBLIC, the overriding one must not be
4067 if (old->n.tb->access == ACCESS_PUBLIC
4068 && proc->n.tb->access == ACCESS_PRIVATE)
4070 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4071 " PRIVATE", proc->name, &where);
4075 /* Compare the formal argument lists of both procedures. This is also abused
4076 to find the position of the passed-object dummy arguments of both
4077 bindings as at least the overridden one might not yet be resolved and we
4078 need those positions in the check below. */
4079 proc_pass_arg = old_pass_arg = 0;
4080 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4082 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4085 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
4086 proc_formal && old_formal;
4087 proc_formal = proc_formal->next, old_formal = old_formal->next)
4089 if (proc->n.tb->pass_arg
4090 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4091 proc_pass_arg = argpos;
4092 if (old->n.tb->pass_arg
4093 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4094 old_pass_arg = argpos;
4096 /* Check that the names correspond. */
4097 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4099 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4100 " to match the corresponding argument of the overridden"
4101 " procedure", proc_formal->sym->name, proc->name, &where,
4102 old_formal->sym->name);
4106 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4107 if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4108 check_type, err, sizeof(err)) == FAILURE)
4110 gfc_error ("Argument mismatch for the overriding procedure "
4111 "'%s' at %L: %s", proc->name, &where, err);
4117 if (proc_formal || old_formal)
4119 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4120 " the overridden procedure", proc->name, &where);
4124 /* If the overridden binding is NOPASS, the overriding one must also be
4126 if (old->n.tb->nopass && !proc->n.tb->nopass)
4128 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4129 " NOPASS", proc->name, &where);
4133 /* If the overridden binding is PASS(x), the overriding one must also be
4134 PASS and the passed-object dummy arguments must correspond. */
4135 if (!old->n.tb->nopass)
4137 if (proc->n.tb->nopass)
4139 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4140 " PASS", proc->name, &where);
4144 if (proc_pass_arg != old_pass_arg)
4146 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4147 " the same position as the passed-object dummy argument of"
4148 " the overridden procedure", proc->name, &where);