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 != ts2->type
490 && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
491 || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
493 if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
494 return (ts1->kind == ts2->kind);
496 /* Compare derived types. */
497 if (gfc_type_compatible (ts1, ts2))
500 return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
504 /* Given two symbols that are formal arguments, compare their ranks
505 and types. Returns nonzero if they have the same rank and type,
509 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
511 gfc_array_spec *as1, *as2;
514 as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
515 as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
517 r1 = as1 ? as1->rank : 0;
518 r2 = as2 ? as2->rank : 0;
521 && (!as1 || as1->type != AS_ASSUMED_RANK)
522 && (!as2 || as2->type != AS_ASSUMED_RANK))
523 return 0; /* Ranks differ. */
525 return gfc_compare_types (&s1->ts, &s2->ts)
526 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
530 /* Given two symbols that are formal arguments, compare their types
531 and rank and their formal interfaces if they are both dummy
532 procedures. Returns nonzero if the same, zero if different. */
535 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
537 if (s1 == NULL || s2 == NULL)
538 return s1 == s2 ? 1 : 0;
543 if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
544 return compare_type_rank (s1, s2);
546 if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
549 /* At this point, both symbols are procedures. It can happen that
550 external procedures are compared, where one is identified by usage
551 to be a function or subroutine but the other is not. Check TKR
552 nonetheless for these cases. */
553 if (s1->attr.function == 0 && s1->attr.subroutine == 0)
554 return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
556 if (s2->attr.function == 0 && s2->attr.subroutine == 0)
557 return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
559 /* Now the type of procedure has been identified. */
560 if (s1->attr.function != s2->attr.function
561 || s1->attr.subroutine != s2->attr.subroutine)
564 if (s1->attr.function && compare_type_rank (s1, s2) == 0)
567 /* Originally, gfortran recursed here to check the interfaces of passed
568 procedures. This is explicitly not required by the standard. */
573 /* Given a formal argument list and a keyword name, search the list
574 for that keyword. Returns the correct symbol node if found, NULL
578 find_keyword_arg (const char *name, gfc_formal_arglist *f)
580 for (; f; f = f->next)
581 if (strcmp (f->sym->name, name) == 0)
588 /******** Interface checking subroutines **********/
591 /* Given an operator interface and the operator, make sure that all
592 interfaces for that operator are legal. */
595 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
598 gfc_formal_arglist *formal;
601 int args, r1, r2, k1, k2;
606 t1 = t2 = BT_UNKNOWN;
607 i1 = i2 = INTENT_UNKNOWN;
611 for (formal = sym->formal; formal; formal = formal->next)
613 gfc_symbol *fsym = formal->sym;
616 gfc_error ("Alternate return cannot appear in operator "
617 "interface at %L", &sym->declared_at);
623 i1 = fsym->attr.intent;
624 r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
630 i2 = fsym->attr.intent;
631 r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
637 /* Only +, - and .not. can be unary operators.
638 .not. cannot be a binary operator. */
639 if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
640 && op != INTRINSIC_MINUS
641 && op != INTRINSIC_NOT)
642 || (args == 2 && op == INTRINSIC_NOT))
644 if (op == INTRINSIC_ASSIGN)
645 gfc_error ("Assignment operator interface at %L must have "
646 "two arguments", &sym->declared_at);
648 gfc_error ("Operator interface at %L has the wrong number of arguments",
653 /* Check that intrinsics are mapped to functions, except
654 INTRINSIC_ASSIGN which should map to a subroutine. */
655 if (op == INTRINSIC_ASSIGN)
657 if (!sym->attr.subroutine)
659 gfc_error ("Assignment operator interface at %L must be "
660 "a SUBROUTINE", &sym->declared_at);
664 /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
665 - First argument an array with different rank than second,
666 - First argument is a scalar and second an array,
667 - Types and kinds do not conform, or
668 - First argument is of derived type. */
669 if (sym->formal->sym->ts.type != BT_DERIVED
670 && sym->formal->sym->ts.type != BT_CLASS
671 && (r2 == 0 || r1 == r2)
672 && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
673 || (gfc_numeric_ts (&sym->formal->sym->ts)
674 && gfc_numeric_ts (&sym->formal->next->sym->ts))))
676 gfc_error ("Assignment operator interface at %L must not redefine "
677 "an INTRINSIC type assignment", &sym->declared_at);
683 if (!sym->attr.function)
685 gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
691 /* Check intents on operator interfaces. */
692 if (op == INTRINSIC_ASSIGN)
694 if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
696 gfc_error ("First argument of defined assignment at %L must be "
697 "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
703 gfc_error ("Second argument of defined assignment at %L must be "
704 "INTENT(IN)", &sym->declared_at);
712 gfc_error ("First argument of operator interface at %L must be "
713 "INTENT(IN)", &sym->declared_at);
717 if (args == 2 && i2 != INTENT_IN)
719 gfc_error ("Second argument of operator interface at %L must be "
720 "INTENT(IN)", &sym->declared_at);
725 /* From now on, all we have to do is check that the operator definition
726 doesn't conflict with an intrinsic operator. The rules for this
727 game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
728 as well as 12.3.2.1.1 of Fortran 2003:
730 "If the operator is an intrinsic-operator (R310), the number of
731 function arguments shall be consistent with the intrinsic uses of
732 that operator, and the types, kind type parameters, or ranks of the
733 dummy arguments shall differ from those required for the intrinsic
734 operation (7.1.2)." */
736 #define IS_NUMERIC_TYPE(t) \
737 ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
739 /* Unary ops are easy, do them first. */
740 if (op == INTRINSIC_NOT)
742 if (t1 == BT_LOGICAL)
748 if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
750 if (IS_NUMERIC_TYPE (t1))
756 /* Character intrinsic operators have same character kind, thus
757 operator definitions with operands of different character kinds
759 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
762 /* Intrinsic operators always perform on arguments of same rank,
763 so different ranks is also always safe. (rank == 0) is an exception
764 to that, because all intrinsic operators are elemental. */
765 if (r1 != r2 && r1 != 0 && r2 != 0)
771 case INTRINSIC_EQ_OS:
773 case INTRINSIC_NE_OS:
774 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
779 case INTRINSIC_MINUS:
780 case INTRINSIC_TIMES:
781 case INTRINSIC_DIVIDE:
782 case INTRINSIC_POWER:
783 if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
788 case INTRINSIC_GT_OS:
790 case INTRINSIC_GE_OS:
792 case INTRINSIC_LT_OS:
794 case INTRINSIC_LE_OS:
795 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
797 if ((t1 == BT_INTEGER || t1 == BT_REAL)
798 && (t2 == BT_INTEGER || t2 == BT_REAL))
802 case INTRINSIC_CONCAT:
803 if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
811 if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
821 #undef IS_NUMERIC_TYPE
824 gfc_error ("Operator interface at %L conflicts with intrinsic interface",
830 /* Given a pair of formal argument lists, we see if the two lists can
831 be distinguished by counting the number of nonoptional arguments of
832 a given type/rank in f1 and seeing if there are less then that
833 number of those arguments in f2 (including optional arguments).
834 Since this test is asymmetric, it has to be called twice to make it
835 symmetric. Returns nonzero if the argument lists are incompatible
836 by this test. This subroutine implements rule 1 of section F03:16.2.3.
837 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
840 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
841 const char *p1, const char *p2)
843 int rc, ac1, ac2, i, j, k, n1;
844 gfc_formal_arglist *f;
857 for (f = f1; f; f = f->next)
860 /* Build an array of integers that gives the same integer to
861 arguments of the same type/rank. */
862 arg = XCNEWVEC (arginfo, n1);
865 for (i = 0; i < n1; i++, f = f->next)
873 for (i = 0; i < n1; i++)
875 if (arg[i].flag != -1)
878 if (arg[i].sym && (arg[i].sym->attr.optional
879 || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
880 continue; /* Skip OPTIONAL and PASS arguments. */
884 /* Find other non-optional, non-pass arguments of the same type/rank. */
885 for (j = i + 1; j < n1; j++)
886 if ((arg[j].sym == NULL
887 || !(arg[j].sym->attr.optional
888 || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
889 && (compare_type_rank_if (arg[i].sym, arg[j].sym)
890 || compare_type_rank_if (arg[j].sym, arg[i].sym)))
896 /* Now loop over each distinct type found in f1. */
900 for (i = 0; i < n1; i++)
902 if (arg[i].flag != k)
906 for (j = i + 1; j < n1; j++)
907 if (arg[j].flag == k)
910 /* Count the number of non-pass arguments in f2 with that type,
911 including those that are optional. */
914 for (f = f2; f; f = f->next)
915 if ((!p2 || strcmp (f->sym->name, p2) != 0)
916 && (compare_type_rank_if (arg[i].sym, f->sym)
917 || compare_type_rank_if (f->sym, arg[i].sym)))
935 /* Perform the correspondence test in rule (3) of F08:C1215.
936 Returns zero if no argument is found that satisfies this rule,
937 nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures
940 This test is also not symmetric in f1 and f2 and must be called
941 twice. This test finds problems caused by sorting the actual
942 argument list with keywords. For example:
946 INTEGER :: A ; REAL :: B
950 INTEGER :: A ; REAL :: B
954 At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
957 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
958 const char *p1, const char *p2)
960 gfc_formal_arglist *f2_save, *g;
967 if (f1->sym->attr.optional)
970 if (p1 && strcmp (f1->sym->name, p1) == 0)
972 if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
975 if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
976 || compare_type_rank (f2->sym, f1->sym))
977 && !((gfc_option.allow_std & GFC_STD_F2008)
978 && ((f1->sym->attr.allocatable && f2->sym->attr.pointer)
979 || (f2->sym->attr.allocatable && f1->sym->attr.pointer))))
982 /* Now search for a disambiguating keyword argument starting at
983 the current non-match. */
984 for (g = f1; g; g = g->next)
986 if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
989 sym = find_keyword_arg (g->sym->name, f2_save);
990 if (sym == NULL || !compare_type_rank (g->sym, sym)
991 || ((gfc_option.allow_std & GFC_STD_F2008)
992 && ((sym->attr.allocatable && g->sym->attr.pointer)
993 || (sym->attr.pointer && g->sym->attr.allocatable))))
1008 /* Check if the characteristics of two dummy arguments match,
1012 check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1013 bool type_must_agree, char *errmsg, int err_len)
1015 /* Check type and rank. */
1016 if (type_must_agree && !compare_type_rank (s2, s1))
1018 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1024 if (s1->attr.intent != s2->attr.intent)
1026 snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1031 /* Check OPTIONAL attribute. */
1032 if (s1->attr.optional != s2->attr.optional)
1034 snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1039 /* Check ALLOCATABLE attribute. */
1040 if (s1->attr.allocatable != s2->attr.allocatable)
1042 snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
1047 /* Check POINTER attribute. */
1048 if (s1->attr.pointer != s2->attr.pointer)
1050 snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
1055 /* Check TARGET attribute. */
1056 if (s1->attr.target != s2->attr.target)
1058 snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
1063 /* FIXME: Do more comprehensive testing of attributes, like e.g.
1064 ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
1066 /* Check interface of dummy procedures. */
1067 if (s1->attr.flavor == FL_PROCEDURE)
1070 if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err),
1073 snprintf (errmsg, err_len, "Interface mismatch in dummy procedure "
1074 "'%s': %s", s1->name, err);
1079 /* Check string length. */
1080 if (s1->ts.type == BT_CHARACTER
1081 && s1->ts.u.cl && s1->ts.u.cl->length
1082 && s2->ts.u.cl && s2->ts.u.cl->length)
1084 int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
1085 s2->ts.u.cl->length);
1091 snprintf (errmsg, err_len, "Character length mismatch "
1092 "in argument '%s'", s1->name);
1096 /* FIXME: Implement a warning for this case.
1097 gfc_warning ("Possible character length mismatch in argument '%s'",
1105 gfc_internal_error ("check_dummy_characteristics: Unexpected result "
1106 "%i of gfc_dep_compare_expr", compval);
1111 /* Check array shape. */
1112 if (s1->as && s2->as)
1115 gfc_expr *shape1, *shape2;
1117 if (s1->as->type != s2->as->type)
1119 snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
1124 if (s1->as->type == AS_EXPLICIT)
1125 for (i = 0; i < s1->as->rank + s1->as->corank; i++)
1127 shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
1128 gfc_copy_expr (s1->as->lower[i]));
1129 shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]),
1130 gfc_copy_expr (s2->as->lower[i]));
1131 compval = gfc_dep_compare_expr (shape1, shape2);
1132 gfc_free_expr (shape1);
1133 gfc_free_expr (shape2);
1139 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1140 "argument '%s'", i + 1, s1->name);
1144 /* FIXME: Implement a warning for this case.
1145 gfc_warning ("Possible shape mismatch in argument '%s'",
1153 gfc_internal_error ("check_dummy_characteristics: Unexpected "
1154 "result %i of gfc_dep_compare_expr",
1165 /* Check if the characteristics of two function results match,
1169 check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
1170 char *errmsg, int err_len)
1172 gfc_symbol *r1, *r2;
1174 r1 = s1->result ? s1->result : s1;
1175 r2 = s2->result ? s2->result : s2;
1177 if (r1->ts.type == BT_UNKNOWN)
1180 /* Check type and rank. */
1181 if (!compare_type_rank (r1, r2))
1183 snprintf (errmsg, err_len, "Type/rank mismatch in function result");
1187 /* Check ALLOCATABLE attribute. */
1188 if (r1->attr.allocatable != r2->attr.allocatable)
1190 snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
1195 /* Check POINTER attribute. */
1196 if (r1->attr.pointer != r2->attr.pointer)
1198 snprintf (errmsg, err_len, "POINTER attribute mismatch in "
1203 /* Check CONTIGUOUS attribute. */
1204 if (r1->attr.contiguous != r2->attr.contiguous)
1206 snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
1211 /* Check PROCEDURE POINTER attribute. */
1212 if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
1214 snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
1219 /* Check string length. */
1220 if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
1222 if (r1->ts.deferred != r2->ts.deferred)
1224 snprintf (errmsg, err_len, "Character length mismatch "
1225 "in function result");
1229 if (r1->ts.u.cl->length)
1231 int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
1232 r2->ts.u.cl->length);
1238 snprintf (errmsg, err_len, "Character length mismatch "
1239 "in function result");
1243 /* FIXME: Implement a warning for this case.
1244 snprintf (errmsg, err_len, "Possible character length mismatch "
1245 "in function result");*/
1252 gfc_internal_error ("check_result_characteristics (1): Unexpected "
1253 "result %i of gfc_dep_compare_expr", compval);
1259 /* Check array shape. */
1260 if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
1263 gfc_expr *shape1, *shape2;
1265 if (r1->as->type != r2->as->type)
1267 snprintf (errmsg, err_len, "Shape mismatch in function result");
1271 if (r1->as->type == AS_EXPLICIT)
1272 for (i = 0; i < r1->as->rank + r1->as->corank; i++)
1274 shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
1275 gfc_copy_expr (r1->as->lower[i]));
1276 shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
1277 gfc_copy_expr (r2->as->lower[i]));
1278 compval = gfc_dep_compare_expr (shape1, shape2);
1279 gfc_free_expr (shape1);
1280 gfc_free_expr (shape2);
1286 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
1287 "function result", i + 1);
1291 /* FIXME: Implement a warning for this case.
1292 gfc_warning ("Possible shape mismatch in return value");*/
1299 gfc_internal_error ("check_result_characteristics (2): "
1300 "Unexpected result %i of "
1301 "gfc_dep_compare_expr", compval);
1311 /* 'Compare' two formal interfaces associated with a pair of symbols.
1312 We return nonzero if there exists an actual argument list that
1313 would be ambiguous between the two interfaces, zero otherwise.
1314 'strict_flag' specifies whether all the characteristics are
1315 required to match, which is not the case for ambiguity checks.
1316 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
1319 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
1320 int generic_flag, int strict_flag,
1321 char *errmsg, int err_len,
1322 const char *p1, const char *p2)
1324 gfc_formal_arglist *f1, *f2;
1326 gcc_assert (name2 != NULL);
1328 if (s1->attr.function && (s2->attr.subroutine
1329 || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
1330 && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
1333 snprintf (errmsg, err_len, "'%s' is not a function", name2);
1337 if (s1->attr.subroutine && s2->attr.function)
1340 snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
1344 /* Do strict checks on all characteristics
1345 (for dummy procedures and procedure pointer assignments). */
1346 if (!generic_flag && strict_flag)
1348 if (s1->attr.function && s2->attr.function)
1350 /* If both are functions, check result characteristics. */
1351 if (check_result_characteristics (s1, s2, errmsg, err_len)
1356 if (s1->attr.pure && !s2->attr.pure)
1358 snprintf (errmsg, err_len, "Mismatch in PURE attribute");
1361 if (s1->attr.elemental && !s2->attr.elemental)
1363 snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
1368 if (s1->attr.if_source == IFSRC_UNKNOWN
1369 || s2->attr.if_source == IFSRC_UNKNOWN)
1375 if (f1 == NULL && f2 == NULL)
1376 return 1; /* Special case: No arguments. */
1380 if (count_types_test (f1, f2, p1, p2)
1381 || count_types_test (f2, f1, p2, p1))
1383 if (generic_correspondence (f1, f2, p1, p2)
1384 || generic_correspondence (f2, f1, p2, p1))
1388 /* Perform the abbreviated correspondence test for operators (the
1389 arguments cannot be optional and are always ordered correctly).
1390 This is also done when comparing interfaces for dummy procedures and in
1391 procedure pointer assignments. */
1395 /* Check existence. */
1396 if (f1 == NULL && f2 == NULL)
1398 if (f1 == NULL || f2 == NULL)
1401 snprintf (errmsg, err_len, "'%s' has the wrong number of "
1402 "arguments", name2);
1408 /* Check all characteristics. */
1409 if (check_dummy_characteristics (f1->sym, f2->sym,
1410 true, errmsg, err_len) == FAILURE)
1413 else if (!compare_type_rank (f2->sym, f1->sym))
1415 /* Only check type and rank. */
1417 snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1430 /* Given a pointer to an interface pointer, remove duplicate
1431 interfaces and make sure that all symbols are either functions
1432 or subroutines, and all of the same kind. Returns nonzero if
1433 something goes wrong. */
1436 check_interface0 (gfc_interface *p, const char *interface_name)
1438 gfc_interface *psave, *q, *qlast;
1441 for (; p; p = p->next)
1443 /* Make sure all symbols in the interface have been defined as
1444 functions or subroutines. */
1445 if (((!p->sym->attr.function && !p->sym->attr.subroutine)
1446 || !p->sym->attr.if_source)
1447 && p->sym->attr.flavor != FL_DERIVED)
1449 if (p->sym->attr.external)
1450 gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1451 p->sym->name, interface_name, &p->sym->declared_at);
1453 gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1454 "subroutine", p->sym->name, interface_name,
1455 &p->sym->declared_at);
1459 /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
1460 if ((psave->sym->attr.function && !p->sym->attr.function
1461 && p->sym->attr.flavor != FL_DERIVED)
1462 || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
1464 if (p->sym->attr.flavor != FL_DERIVED)
1465 gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
1466 " or all FUNCTIONs", interface_name,
1467 &p->sym->declared_at);
1469 gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
1470 "generic name is also the name of a derived type",
1471 interface_name, &p->sym->declared_at);
1475 /* F2003, C1207. F2008, C1207. */
1476 if (p->sym->attr.proc == PROC_INTERNAL
1477 && gfc_notify_std (GFC_STD_F2008, "Internal procedure "
1478 "'%s' in %s at %L", p->sym->name, interface_name,
1479 &p->sym->declared_at) == FAILURE)
1484 /* Remove duplicate interfaces in this interface list. */
1485 for (; p; p = p->next)
1489 for (q = p->next; q;)
1491 if (p->sym != q->sym)
1498 /* Duplicate interface. */
1499 qlast->next = q->next;
1510 /* Check lists of interfaces to make sure that no two interfaces are
1511 ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
1514 check_interface1 (gfc_interface *p, gfc_interface *q0,
1515 int generic_flag, const char *interface_name,
1519 for (; p; p = p->next)
1520 for (q = q0; q; q = q->next)
1522 if (p->sym == q->sym)
1523 continue; /* Duplicates OK here. */
1525 if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1528 if (p->sym->attr.flavor != FL_DERIVED
1529 && q->sym->attr.flavor != FL_DERIVED
1530 && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
1531 generic_flag, 0, NULL, 0, NULL, NULL))
1534 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1535 p->sym->name, q->sym->name, interface_name,
1537 else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1538 gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1539 p->sym->name, q->sym->name, interface_name,
1542 gfc_warning ("Although not referenced, '%s' has ambiguous "
1543 "interfaces at %L", interface_name, &p->where);
1551 /* Check the generic and operator interfaces of symbols to make sure
1552 that none of the interfaces conflict. The check has to be done
1553 after all of the symbols are actually loaded. */
1556 check_sym_interfaces (gfc_symbol *sym)
1558 char interface_name[100];
1561 if (sym->ns != gfc_current_ns)
1564 if (sym->generic != NULL)
1566 sprintf (interface_name, "generic interface '%s'", sym->name);
1567 if (check_interface0 (sym->generic, interface_name))
1570 for (p = sym->generic; p; p = p->next)
1572 if (sym->attr.access != ACCESS_PRIVATE)
1573 p->sym->attr.public_used = 1;
1575 if (p->sym->attr.mod_proc
1576 && (p->sym->attr.if_source != IFSRC_DECL
1577 || p->sym->attr.procedure))
1579 gfc_error ("'%s' at %L is not a module procedure",
1580 p->sym->name, &p->where);
1585 /* Originally, this test was applied to host interfaces too;
1586 this is incorrect since host associated symbols, from any
1587 source, cannot be ambiguous with local symbols. */
1588 check_interface1 (sym->generic, sym->generic, 1, interface_name,
1589 sym->attr.referenced || !sym->attr.use_assoc);
1595 check_uop_interfaces (gfc_user_op *uop)
1597 char interface_name[100];
1602 sprintf (interface_name, "operator interface '%s'", uop->name);
1603 if (check_interface0 (uop->op, interface_name))
1606 if (uop->access != ACCESS_PRIVATE)
1607 for (p = uop->op; p; p = p->next)
1608 p->sym->attr.public_used = 1;
1610 for (ns = gfc_current_ns; ns; ns = ns->parent)
1612 uop2 = gfc_find_uop (uop->name, ns);
1616 check_interface1 (uop->op, uop2->op, 0,
1617 interface_name, true);
1621 /* Given an intrinsic op, return an equivalent op if one exists,
1622 or INTRINSIC_NONE otherwise. */
1625 gfc_equivalent_op (gfc_intrinsic_op op)
1630 return INTRINSIC_EQ_OS;
1632 case INTRINSIC_EQ_OS:
1633 return INTRINSIC_EQ;
1636 return INTRINSIC_NE_OS;
1638 case INTRINSIC_NE_OS:
1639 return INTRINSIC_NE;
1642 return INTRINSIC_GT_OS;
1644 case INTRINSIC_GT_OS:
1645 return INTRINSIC_GT;
1648 return INTRINSIC_GE_OS;
1650 case INTRINSIC_GE_OS:
1651 return INTRINSIC_GE;
1654 return INTRINSIC_LT_OS;
1656 case INTRINSIC_LT_OS:
1657 return INTRINSIC_LT;
1660 return INTRINSIC_LE_OS;
1662 case INTRINSIC_LE_OS:
1663 return INTRINSIC_LE;
1666 return INTRINSIC_NONE;
1670 /* For the namespace, check generic, user operator and intrinsic
1671 operator interfaces for consistency and to remove duplicate
1672 interfaces. We traverse the whole namespace, counting on the fact
1673 that most symbols will not have generic or operator interfaces. */
1676 gfc_check_interfaces (gfc_namespace *ns)
1678 gfc_namespace *old_ns, *ns2;
1680 char interface_name[100];
1683 old_ns = gfc_current_ns;
1684 gfc_current_ns = ns;
1686 gfc_traverse_ns (ns, check_sym_interfaces);
1688 gfc_traverse_user_op (ns, check_uop_interfaces);
1690 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1692 if (i == INTRINSIC_USER)
1695 if (i == INTRINSIC_ASSIGN)
1696 strcpy (interface_name, "intrinsic assignment operator");
1698 sprintf (interface_name, "intrinsic '%s' operator",
1699 gfc_op2string ((gfc_intrinsic_op) i));
1701 if (check_interface0 (ns->op[i], interface_name))
1704 for (p = ns->op[i]; p; p = p->next)
1705 p->sym->attr.public_used = 1;
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 if (formal->attr.codimension && !gfc_is_coarray (actual))
1939 gfc_error ("Actual argument to '%s' at %L must be a coarray",
1940 formal->name, &actual->where);
1944 if (formal->attr.codimension && formal->attr.allocatable)
1946 gfc_ref *last = NULL;
1948 for (ref = actual->ref; ref; ref = ref->next)
1949 if (ref->type == REF_COMPONENT)
1952 /* F2008, 12.5.2.6. */
1953 if ((last && last->u.c.component->as->corank != formal->as->corank)
1955 && actual->symtree->n.sym->as->corank != formal->as->corank))
1958 gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1959 formal->name, &actual->where, formal->as->corank,
1960 last ? last->u.c.component->as->corank
1961 : actual->symtree->n.sym->as->corank);
1966 if (formal->attr.codimension)
1968 /* F2008, 12.5.2.8. */
1969 if (formal->attr.dimension
1970 && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1971 && gfc_expr_attr (actual).dimension
1972 && !gfc_is_simply_contiguous (actual, true))
1975 gfc_error ("Actual argument to '%s' at %L must be simply "
1976 "contiguous", formal->name, &actual->where);
1980 /* F2008, C1303 and C1304. */
1981 if (formal->attr.intent != INTENT_INOUT
1982 && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
1983 && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
1984 && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
1985 || formal->attr.lock_comp))
1989 gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
1990 "which is LOCK_TYPE or has a LOCK_TYPE component",
1991 formal->name, &actual->where);
1996 /* F2008, C1239/C1240. */
1997 if (actual->expr_type == EXPR_VARIABLE
1998 && (actual->symtree->n.sym->attr.asynchronous
1999 || actual->symtree->n.sym->attr.volatile_)
2000 && (formal->attr.asynchronous || formal->attr.volatile_)
2001 && actual->rank && !gfc_is_simply_contiguous (actual, true)
2002 && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
2003 || formal->attr.contiguous))
2006 gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
2007 "array without CONTIGUOUS attribute - as actual argument at"
2008 " %L is not simply contiguous and both are ASYNCHRONOUS "
2009 "or VOLATILE", formal->name, &actual->where);
2013 if (formal->attr.allocatable && !formal->attr.codimension
2014 && gfc_expr_attr (actual).codimension)
2016 if (formal->attr.intent == INTENT_OUT)
2019 gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
2020 "INTENT(OUT) dummy argument '%s'", &actual->where,
2024 else if (gfc_option.warn_surprising && where
2025 && formal->attr.intent != INTENT_IN)
2026 gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
2027 "argument '%s', which is invalid if the allocation status"
2028 " is modified", &actual->where, formal->name);
2031 /* If the rank is the same or the formal argument has assumed-rank. */
2032 if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
2035 if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
2036 && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
2039 rank_check = where != NULL && !is_elemental && formal->as
2040 && (formal->as->type == AS_ASSUMED_SHAPE
2041 || formal->as->type == AS_DEFERRED)
2042 && actual->expr_type != EXPR_NULL;
2044 /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
2045 if (rank_check || ranks_must_agree
2046 || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
2047 || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
2048 || (actual->rank == 0
2049 && ((formal->ts.type == BT_CLASS
2050 && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE)
2051 || (formal->ts.type != BT_CLASS
2052 && formal->as->type == AS_ASSUMED_SHAPE))
2053 && actual->expr_type != EXPR_NULL)
2054 || (actual->rank == 0 && formal->attr.dimension
2055 && gfc_is_coindexed (actual)))
2058 argument_rank_mismatch (formal->name, &actual->where,
2059 symbol_rank (formal), actual->rank);
2062 else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
2065 /* At this point, we are considering a scalar passed to an array. This
2066 is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
2067 - if the actual argument is (a substring of) an element of a
2068 non-assumed-shape/non-pointer/non-polymorphic array; or
2069 - (F2003) if the actual argument is of type character of default/c_char
2072 is_pointer = actual->expr_type == EXPR_VARIABLE
2073 ? actual->symtree->n.sym->attr.pointer : false;
2075 for (ref = actual->ref; ref; ref = ref->next)
2077 if (ref->type == REF_COMPONENT)
2078 is_pointer = ref->u.c.component->attr.pointer;
2079 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2080 && ref->u.ar.dimen > 0
2082 || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
2086 if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
2089 gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
2090 "at %L", formal->name, &actual->where);
2094 if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
2095 && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2098 gfc_error ("Element of assumed-shaped or pointer "
2099 "array passed to array dummy argument '%s' at %L",
2100 formal->name, &actual->where);
2104 if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
2105 && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
2107 if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
2110 gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
2111 "CHARACTER actual argument with array dummy argument "
2112 "'%s' at %L", formal->name, &actual->where);
2116 if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
2118 gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
2119 "array dummy argument '%s' at %L",
2120 formal->name, &actual->where);
2123 else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
2129 if (ref == NULL && actual->expr_type != EXPR_NULL)
2132 argument_rank_mismatch (formal->name, &actual->where,
2133 symbol_rank (formal), actual->rank);
2141 /* Returns the storage size of a symbol (formal argument) or
2142 zero if it cannot be determined. */
2144 static unsigned long
2145 get_sym_storage_size (gfc_symbol *sym)
2148 unsigned long strlen, elements;
2150 if (sym->ts.type == BT_CHARACTER)
2152 if (sym->ts.u.cl && sym->ts.u.cl->length
2153 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2154 strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
2161 if (symbol_rank (sym) == 0)
2165 if (sym->as->type != AS_EXPLICIT)
2167 for (i = 0; i < sym->as->rank; i++)
2169 if (sym->as->upper[i]->expr_type != EXPR_CONSTANT
2170 || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
2173 elements *= mpz_get_si (sym->as->upper[i]->value.integer)
2174 - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
2177 return strlen*elements;
2181 /* Returns the storage size of an expression (actual argument) or
2182 zero if it cannot be determined. For an array element, it returns
2183 the remaining size as the element sequence consists of all storage
2184 units of the actual argument up to the end of the array. */
2186 static unsigned long
2187 get_expr_storage_size (gfc_expr *e)
2190 long int strlen, elements;
2191 long int substrlen = 0;
2192 bool is_str_storage = false;
2198 if (e->ts.type == BT_CHARACTER)
2200 if (e->ts.u.cl && e->ts.u.cl->length
2201 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2202 strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
2203 else if (e->expr_type == EXPR_CONSTANT
2204 && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
2205 strlen = e->value.character.length;
2210 strlen = 1; /* Length per element. */
2212 if (e->rank == 0 && !e->ref)
2220 for (i = 0; i < e->rank; i++)
2221 elements *= mpz_get_si (e->shape[i]);
2222 return elements*strlen;
2225 for (ref = e->ref; ref; ref = ref->next)
2227 if (ref->type == REF_SUBSTRING && ref->u.ss.start
2228 && ref->u.ss.start->expr_type == EXPR_CONSTANT)
2232 /* The string length is the substring length.
2233 Set now to full string length. */
2234 if (!ref->u.ss.length || !ref->u.ss.length->length
2235 || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
2238 strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
2240 substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
2244 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2245 for (i = 0; i < ref->u.ar.dimen; i++)
2247 long int start, end, stride;
2250 if (ref->u.ar.stride[i])
2252 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
2253 stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
2258 if (ref->u.ar.start[i])
2260 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
2261 start = mpz_get_si (ref->u.ar.start[i]->value.integer);
2265 else if (ref->u.ar.as->lower[i]
2266 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
2267 start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
2271 if (ref->u.ar.end[i])
2273 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
2274 end = mpz_get_si (ref->u.ar.end[i]->value.integer);
2278 else if (ref->u.ar.as->upper[i]
2279 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2280 end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
2284 elements *= (end - start)/stride + 1L;
2286 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL)
2287 for (i = 0; i < ref->u.ar.as->rank; i++)
2289 if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
2290 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
2291 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
2292 elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2293 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2298 else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
2299 && e->expr_type == EXPR_VARIABLE)
2301 if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
2302 || e->symtree->n.sym->attr.pointer)
2308 /* Determine the number of remaining elements in the element
2309 sequence for array element designators. */
2310 is_str_storage = true;
2311 for (i = ref->u.ar.dimen - 1; i >= 0; i--)
2313 if (ref->u.ar.start[i] == NULL
2314 || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
2315 || ref->u.ar.as->upper[i] == NULL
2316 || ref->u.ar.as->lower[i] == NULL
2317 || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
2318 || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
2323 * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
2324 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
2326 - (mpz_get_si (ref->u.ar.start[i]->value.integer)
2327 - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
2333 return (is_str_storage) ? substrlen + (elements-1)*strlen
2336 return elements*strlen;
2340 /* Given an expression, check whether it is an array section
2341 which has a vector subscript. If it has, one is returned,
2345 gfc_has_vector_subscript (gfc_expr *e)
2350 if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
2353 for (ref = e->ref; ref; ref = ref->next)
2354 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2355 for (i = 0; i < ref->u.ar.dimen; i++)
2356 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2363 /* Given formal and actual argument lists, see if they are compatible.
2364 If they are compatible, the actual argument list is sorted to
2365 correspond with the formal list, and elements for missing optional
2366 arguments are inserted. If WHERE pointer is nonnull, then we issue
2367 errors when things don't match instead of just returning the status
2371 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
2372 int ranks_must_agree, int is_elemental, locus *where)
2374 gfc_actual_arglist **new_arg, *a, *actual, temp;
2375 gfc_formal_arglist *f;
2377 unsigned long actual_size, formal_size;
2378 bool full_array = false;
2382 if (actual == NULL && formal == NULL)
2386 for (f = formal; f; f = f->next)
2389 new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
2391 for (i = 0; i < n; i++)
2398 for (a = actual; a; a = a->next, f = f->next)
2400 /* Look for keywords but ignore g77 extensions like %VAL. */
2401 if (a->name != NULL && a->name[0] != '%')
2404 for (f = formal; f; f = f->next, i++)
2408 if (strcmp (f->sym->name, a->name) == 0)
2415 gfc_error ("Keyword argument '%s' at %L is not in "
2416 "the procedure", a->name, &a->expr->where);
2420 if (new_arg[i] != NULL)
2423 gfc_error ("Keyword argument '%s' at %L is already associated "
2424 "with another actual argument", a->name,
2433 gfc_error ("More actual than formal arguments in procedure "
2434 "call at %L", where);
2439 if (f->sym == NULL && a->expr == NULL)
2445 gfc_error ("Missing alternate return spec in subroutine call "
2450 if (a->expr == NULL)
2453 gfc_error ("Unexpected alternate return spec in subroutine "
2454 "call at %L", where);
2458 if (a->expr->expr_type == EXPR_NULL
2459 && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
2460 && (f->sym->attr.allocatable || !f->sym->attr.optional
2461 || (gfc_option.allow_std & GFC_STD_F2008) == 0))
2462 || (f->sym->ts.type == BT_CLASS
2463 && !CLASS_DATA (f->sym)->attr.class_pointer
2464 && (CLASS_DATA (f->sym)->attr.allocatable
2465 || !f->sym->attr.optional
2466 || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
2469 && (!f->sym->attr.optional
2470 || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
2471 || (f->sym->ts.type == BT_CLASS
2472 && CLASS_DATA (f->sym)->attr.allocatable)))
2473 gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
2474 where, f->sym->name);
2476 gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
2477 "dummy '%s'", where, f->sym->name);
2482 if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
2483 is_elemental, where))
2486 /* TS 29113, 6.3p2. */
2487 if (f->sym->ts.type == BT_ASSUMED
2488 && (a->expr->ts.type == BT_DERIVED
2489 || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
2491 gfc_namespace *f2k_derived;
2493 f2k_derived = a->expr->ts.type == BT_DERIVED
2494 ? a->expr->ts.u.derived->f2k_derived
2495 : CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
2498 && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
2500 gfc_error ("Actual argument at %L to assumed-type dummy is of "
2501 "derived type with type-bound or FINAL procedures",
2507 /* Special case for character arguments. For allocatable, pointer
2508 and assumed-shape dummies, the string length needs to match
2510 if (a->expr->ts.type == BT_CHARACTER
2511 && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2512 && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2513 && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2514 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2515 && (f->sym->attr.pointer || f->sym->attr.allocatable
2516 || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2517 && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2518 f->sym->ts.u.cl->length->value.integer) != 0))
2520 if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2521 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2522 "argument and pointer or allocatable dummy argument "
2524 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2525 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2526 f->sym->name, &a->expr->where);
2528 gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2529 "argument and assumed-shape dummy argument '%s' "
2531 mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2532 mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2533 f->sym->name, &a->expr->where);
2537 if ((f->sym->attr.pointer || f->sym->attr.allocatable)
2538 && f->sym->ts.deferred != a->expr->ts.deferred
2539 && a->expr->ts.type == BT_CHARACTER)
2542 gfc_error ("Actual argument at %L to allocatable or "
2543 "pointer dummy argument '%s' must have a deferred "
2544 "length type parameter if and only if the dummy has one",
2545 &a->expr->where, f->sym->name);
2549 if (f->sym->ts.type == BT_CLASS)
2550 goto skip_size_check;
2552 actual_size = get_expr_storage_size (a->expr);
2553 formal_size = get_sym_storage_size (f->sym);
2554 if (actual_size != 0 && actual_size < formal_size
2555 && a->expr->ts.type != BT_PROCEDURE
2556 && f->sym->attr.flavor != FL_PROCEDURE)
2558 if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2559 gfc_warning ("Character length of actual argument shorter "
2560 "than of dummy argument '%s' (%lu/%lu) at %L",
2561 f->sym->name, actual_size, formal_size,
2564 gfc_warning ("Actual argument contains too few "
2565 "elements for dummy argument '%s' (%lu/%lu) at %L",
2566 f->sym->name, actual_size, formal_size,
2573 /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
2574 argument is provided for a procedure pointer formal argument. */
2575 if (f->sym->attr.proc_pointer
2576 && !((a->expr->expr_type == EXPR_VARIABLE
2577 && a->expr->symtree->n.sym->attr.proc_pointer)
2578 || (a->expr->expr_type == EXPR_FUNCTION
2579 && a->expr->symtree->n.sym->result->attr.proc_pointer)
2580 || gfc_is_proc_ptr_comp (a->expr)))
2583 gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2584 f->sym->name, &a->expr->where);
2588 /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
2589 provided for a procedure formal argument. */
2590 if (f->sym->attr.flavor == FL_PROCEDURE
2591 && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
2594 gfc_error ("Expected a procedure for argument '%s' at %L",
2595 f->sym->name, &a->expr->where);
2599 if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2600 && a->expr->expr_type == EXPR_VARIABLE
2601 && a->expr->symtree->n.sym->as
2602 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2603 && (a->expr->ref == NULL
2604 || (a->expr->ref->type == REF_ARRAY
2605 && a->expr->ref->u.ar.type == AR_FULL)))
2608 gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2609 " array at %L", f->sym->name, where);
2613 if (a->expr->expr_type != EXPR_NULL
2614 && compare_pointer (f->sym, a->expr) == 0)
2617 gfc_error ("Actual argument for '%s' must be a pointer at %L",
2618 f->sym->name, &a->expr->where);
2622 if (a->expr->expr_type != EXPR_NULL
2623 && (gfc_option.allow_std & GFC_STD_F2008) == 0
2624 && compare_pointer (f->sym, a->expr) == 2)
2627 gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2628 "pointer dummy '%s'", &a->expr->where,f->sym->name);
2633 /* Fortran 2008, C1242. */
2634 if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2637 gfc_error ("Coindexed actual argument at %L to pointer "
2639 &a->expr->where, f->sym->name);
2643 /* Fortran 2008, 12.5.2.5 (no constraint). */
2644 if (a->expr->expr_type == EXPR_VARIABLE
2645 && f->sym->attr.intent != INTENT_IN
2646 && f->sym->attr.allocatable
2647 && gfc_is_coindexed (a->expr))
2650 gfc_error ("Coindexed actual argument at %L to allocatable "
2651 "dummy '%s' requires INTENT(IN)",
2652 &a->expr->where, f->sym->name);
2656 /* Fortran 2008, C1237. */
2657 if (a->expr->expr_type == EXPR_VARIABLE
2658 && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2659 && gfc_is_coindexed (a->expr)
2660 && (a->expr->symtree->n.sym->attr.volatile_
2661 || a->expr->symtree->n.sym->attr.asynchronous))
2664 gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2665 "%L requires that dummy '%s' has neither "
2666 "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2671 /* Fortran 2008, 12.5.2.4 (no constraint). */
2672 if (a->expr->expr_type == EXPR_VARIABLE
2673 && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2674 && gfc_is_coindexed (a->expr)
2675 && gfc_has_ultimate_allocatable (a->expr))
2678 gfc_error ("Coindexed actual argument at %L with allocatable "
2679 "ultimate component to dummy '%s' requires either VALUE "
2680 "or INTENT(IN)", &a->expr->where, f->sym->name);
2684 if (f->sym->ts.type == BT_CLASS
2685 && CLASS_DATA (f->sym)->attr.allocatable
2686 && gfc_is_class_array_ref (a->expr, &full_array)
2690 gfc_error ("Actual CLASS array argument for '%s' must be a full "
2691 "array at %L", f->sym->name, &a->expr->where);
2696 if (a->expr->expr_type != EXPR_NULL
2697 && compare_allocatable (f->sym, a->expr) == 0)
2700 gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2701 f->sym->name, &a->expr->where);
2705 /* Check intent = OUT/INOUT for definable actual argument. */
2706 if ((f->sym->attr.intent == INTENT_OUT
2707 || f->sym->attr.intent == INTENT_INOUT))
2709 const char* context = (where
2710 ? _("actual argument to INTENT = OUT/INOUT")
2713 if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
2714 && CLASS_DATA (f->sym)->attr.class_pointer)
2715 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
2716 && gfc_check_vardef_context (a->expr, true, false, false, context)
2719 if (gfc_check_vardef_context (a->expr, false, false, false, context)
2724 if ((f->sym->attr.intent == INTENT_OUT
2725 || f->sym->attr.intent == INTENT_INOUT
2726 || f->sym->attr.volatile_
2727 || f->sym->attr.asynchronous)
2728 && gfc_has_vector_subscript (a->expr))
2731 gfc_error ("Array-section actual argument with vector "
2732 "subscripts at %L is incompatible with INTENT(OUT), "
2733 "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2734 "of the dummy argument '%s'",
2735 &a->expr->where, f->sym->name);
2739 /* C1232 (R1221) For an actual argument which is an array section or
2740 an assumed-shape array, the dummy argument shall be an assumed-
2741 shape array, if the dummy argument has the VOLATILE attribute. */
2743 if (f->sym->attr.volatile_
2744 && a->expr->symtree->n.sym->as
2745 && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2746 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2749 gfc_error ("Assumed-shape actual argument at %L is "
2750 "incompatible with the non-assumed-shape "
2751 "dummy argument '%s' due to VOLATILE attribute",
2752 &a->expr->where,f->sym->name);
2756 if (f->sym->attr.volatile_
2757 && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2758 && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2761 gfc_error ("Array-section actual argument at %L is "
2762 "incompatible with the non-assumed-shape "
2763 "dummy argument '%s' due to VOLATILE attribute",
2764 &a->expr->where,f->sym->name);
2768 /* C1233 (R1221) For an actual argument which is a pointer array, the
2769 dummy argument shall be an assumed-shape or pointer array, if the
2770 dummy argument has the VOLATILE attribute. */
2772 if (f->sym->attr.volatile_
2773 && a->expr->symtree->n.sym->attr.pointer
2774 && a->expr->symtree->n.sym->as
2776 && (f->sym->as->type == AS_ASSUMED_SHAPE
2777 || f->sym->attr.pointer)))
2780 gfc_error ("Pointer-array actual argument at %L requires "
2781 "an assumed-shape or pointer-array dummy "
2782 "argument '%s' due to VOLATILE attribute",
2783 &a->expr->where,f->sym->name);
2794 /* Make sure missing actual arguments are optional. */
2796 for (f = formal; f; f = f->next, i++)
2798 if (new_arg[i] != NULL)
2803 gfc_error ("Missing alternate return spec in subroutine call "
2807 if (!f->sym->attr.optional)
2810 gfc_error ("Missing actual argument for argument '%s' at %L",
2811 f->sym->name, where);
2816 /* The argument lists are compatible. We now relink a new actual
2817 argument list with null arguments in the right places. The head
2818 of the list remains the head. */
2819 for (i = 0; i < n; i++)
2820 if (new_arg[i] == NULL)
2821 new_arg[i] = gfc_get_actual_arglist ();
2826 *new_arg[0] = *actual;
2830 new_arg[0] = new_arg[na];
2834 for (i = 0; i < n - 1; i++)
2835 new_arg[i]->next = new_arg[i + 1];
2837 new_arg[i]->next = NULL;
2839 if (*ap == NULL && n > 0)
2842 /* Note the types of omitted optional arguments. */
2843 for (a = *ap, f = formal; a; a = a->next, f = f->next)
2844 if (a->expr == NULL && a->label == NULL)
2845 a->missing_arg_type = f->sym->ts.type;
2853 gfc_formal_arglist *f;
2854 gfc_actual_arglist *a;
2858 /* qsort comparison function for argument pairs, with the following
2860 - p->a->expr == NULL
2861 - p->a->expr->expr_type != EXPR_VARIABLE
2862 - growing p->a->expr->symbol. */
2865 pair_cmp (const void *p1, const void *p2)
2867 const gfc_actual_arglist *a1, *a2;
2869 /* *p1 and *p2 are elements of the to-be-sorted array. */
2870 a1 = ((const argpair *) p1)->a;
2871 a2 = ((const argpair *) p2)->a;
2880 if (a1->expr->expr_type != EXPR_VARIABLE)
2882 if (a2->expr->expr_type != EXPR_VARIABLE)
2886 if (a2->expr->expr_type != EXPR_VARIABLE)
2888 return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2892 /* Given two expressions from some actual arguments, test whether they
2893 refer to the same expression. The analysis is conservative.
2894 Returning FAILURE will produce no warning. */
2897 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2899 const gfc_ref *r1, *r2;
2902 || e1->expr_type != EXPR_VARIABLE
2903 || e2->expr_type != EXPR_VARIABLE
2904 || e1->symtree->n.sym != e2->symtree->n.sym)
2907 /* TODO: improve comparison, see expr.c:show_ref(). */
2908 for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2910 if (r1->type != r2->type)
2915 if (r1->u.ar.type != r2->u.ar.type)
2917 /* TODO: At the moment, consider only full arrays;
2918 we could do better. */
2919 if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2924 if (r1->u.c.component != r2->u.c.component)
2932 gfc_internal_error ("compare_actual_expr(): Bad component code");
2941 /* Given formal and actual argument lists that correspond to one
2942 another, check that identical actual arguments aren't not
2943 associated with some incompatible INTENTs. */
2946 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2948 sym_intent f1_intent, f2_intent;
2949 gfc_formal_arglist *f1;
2950 gfc_actual_arglist *a1;
2953 gfc_try t = SUCCESS;
2956 for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2958 if (f1 == NULL && a1 == NULL)
2960 if (f1 == NULL || a1 == NULL)
2961 gfc_internal_error ("check_some_aliasing(): List mismatch");
2966 p = XALLOCAVEC (argpair, n);
2968 for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2974 qsort (p, n, sizeof (argpair), pair_cmp);
2976 for (i = 0; i < n; i++)
2979 || p[i].a->expr->expr_type != EXPR_VARIABLE
2980 || p[i].a->expr->ts.type == BT_PROCEDURE)
2982 f1_intent = p[i].f->sym->attr.intent;
2983 for (j = i + 1; j < n; j++)
2985 /* Expected order after the sort. */
2986 if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2987 gfc_internal_error ("check_some_aliasing(): corrupted data");
2989 /* Are the expression the same? */
2990 if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2992 f2_intent = p[j].f->sym->attr.intent;
2993 if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2994 || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2996 gfc_warning ("Same actual argument associated with INTENT(%s) "
2997 "argument '%s' and INTENT(%s) argument '%s' at %L",
2998 gfc_intent_string (f1_intent), p[i].f->sym->name,
2999 gfc_intent_string (f2_intent), p[j].f->sym->name,
3000 &p[i].a->expr->where);
3010 /* Given formal and actual argument lists that correspond to one
3011 another, check that they are compatible in the sense that intents
3012 are not mismatched. */
3015 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
3017 sym_intent f_intent;
3019 for (;; f = f->next, a = a->next)
3021 if (f == NULL && a == NULL)
3023 if (f == NULL || a == NULL)
3024 gfc_internal_error ("check_intents(): List mismatch");
3026 if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
3029 f_intent = f->sym->attr.intent;
3031 if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
3033 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3034 && CLASS_DATA (f->sym)->attr.class_pointer)
3035 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3037 gfc_error ("Procedure argument at %L is local to a PURE "
3038 "procedure and has the POINTER attribute",
3044 /* Fortran 2008, C1283. */
3045 if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
3047 if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
3049 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3050 "is passed to an INTENT(%s) argument",
3051 &a->expr->where, gfc_intent_string (f_intent));
3055 if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
3056 && CLASS_DATA (f->sym)->attr.class_pointer)
3057 || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
3059 gfc_error ("Coindexed actual argument at %L in PURE procedure "
3060 "is passed to a POINTER dummy argument",
3066 /* F2008, Section 12.5.2.4. */
3067 if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
3068 && gfc_is_coindexed (a->expr))
3070 gfc_error ("Coindexed polymorphic actual argument at %L is passed "
3071 "polymorphic dummy argument '%s'",
3072 &a->expr->where, f->sym->name);
3081 /* Check how a procedure is used against its interface. If all goes
3082 well, the actual argument list will also end up being properly
3086 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
3088 /* Warn about calls with an implicit interface. Special case
3089 for calling a ISO_C_BINDING becase c_loc and c_funloc
3090 are pseudo-unknown. Additionally, warn about procedures not
3091 explicitly declared at all if requested. */
3092 if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
3094 if (gfc_option.warn_implicit_interface)
3095 gfc_warning ("Procedure '%s' called with an implicit interface at %L",
3097 else if (gfc_option.warn_implicit_procedure
3098 && sym->attr.proc == PROC_UNKNOWN)
3099 gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
3103 if (sym->attr.if_source == IFSRC_UNKNOWN)
3105 gfc_actual_arglist *a;
3107 if (sym->attr.pointer)
3109 gfc_error("The pointer object '%s' at %L must have an explicit "
3110 "function interface or be declared as array",
3115 if (sym->attr.allocatable && !sym->attr.external)
3117 gfc_error("The allocatable object '%s' at %L must have an explicit "
3118 "function interface or be declared as array",
3123 if (sym->attr.allocatable)
3125 gfc_error("Allocatable function '%s' at %L must have an explicit "
3126 "function interface", sym->name, where);
3130 for (a = *ap; a; a = a->next)
3132 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3133 if (a->name != NULL && a->name[0] != '%')
3135 gfc_error("Keyword argument requires explicit interface "
3136 "for procedure '%s' at %L", sym->name, &a->expr->where);
3140 /* TS 29113, 6.2. */
3141 if (a->expr && a->expr->ts.type == BT_ASSUMED
3142 && sym->intmod_sym_id != ISOCBINDING_LOC)
3144 gfc_error ("Assumed-type argument %s at %L requires an explicit "
3145 "interface", a->expr->symtree->n.sym->name,
3150 /* F2008, C1303 and C1304. */
3152 && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
3153 && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3154 && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3155 || gfc_expr_attr (a->expr).lock_comp))
3157 gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
3158 "component at %L requires an explicit interface for "
3159 "procedure '%s'", &a->expr->where, sym->name);
3163 if (a->expr && a->expr->expr_type == EXPR_NULL
3164 && a->expr->ts.type == BT_UNKNOWN)
3166 gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
3170 /* TS 29113, C407b. */
3171 if (a->expr && a->expr->expr_type == EXPR_VARIABLE
3172 && symbol_rank (a->expr->symtree->n.sym) == -1)
3174 gfc_error ("Assumed-rank argument requires an explicit interface "
3175 "at %L", &a->expr->where);
3183 if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
3186 if (check_intents (sym->formal, *ap) == FAILURE)
3189 if (gfc_option.warn_aliasing)
3190 check_some_aliasing (sym->formal, *ap);
3196 /* Check how a procedure pointer component is used against its interface.
3197 If all goes well, the actual argument list will also end up being properly
3198 sorted. Completely analogous to gfc_procedure_use. */
3201 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
3204 /* Warn about calls with an implicit interface. Special case
3205 for calling a ISO_C_BINDING becase c_loc and c_funloc
3206 are pseudo-unknown. */
3207 if (gfc_option.warn_implicit_interface
3208 && comp->attr.if_source == IFSRC_UNKNOWN
3209 && !comp->attr.is_iso_c)
3210 gfc_warning ("Procedure pointer component '%s' called with an implicit "
3211 "interface at %L", comp->name, where);
3213 if (comp->attr.if_source == IFSRC_UNKNOWN)
3215 gfc_actual_arglist *a;
3216 for (a = *ap; a; a = a->next)
3218 /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
3219 if (a->name != NULL && a->name[0] != '%')
3221 gfc_error("Keyword argument requires explicit interface "
3222 "for procedure pointer component '%s' at %L",
3223 comp->name, &a->expr->where);
3231 if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
3234 check_intents (comp->formal, *ap);
3235 if (gfc_option.warn_aliasing)
3236 check_some_aliasing (comp->formal, *ap);
3240 /* Try if an actual argument list matches the formal list of a symbol,
3241 respecting the symbol's attributes like ELEMENTAL. This is used for
3242 GENERIC resolution. */
3245 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
3249 gcc_assert (sym->attr.flavor == FL_PROCEDURE);
3251 r = !sym->attr.elemental;
3252 if (compare_actual_formal (args, sym->formal, r, !r, NULL))
3254 check_intents (sym->formal, *args);
3255 if (gfc_option.warn_aliasing)
3256 check_some_aliasing (sym->formal, *args);
3264 /* Given an interface pointer and an actual argument list, search for
3265 a formal argument list that matches the actual. If found, returns
3266 a pointer to the symbol of the correct interface. Returns NULL if
3270 gfc_search_interface (gfc_interface *intr, int sub_flag,
3271 gfc_actual_arglist **ap)
3273 gfc_symbol *elem_sym = NULL;
3274 gfc_symbol *null_sym = NULL;
3275 locus null_expr_loc;
3276 gfc_actual_arglist *a;
3277 bool has_null_arg = false;
3279 for (a = *ap; a; a = a->next)
3280 if (a->expr && a->expr->expr_type == EXPR_NULL
3281 && a->expr->ts.type == BT_UNKNOWN)
3283 has_null_arg = true;
3284 null_expr_loc = a->expr->where;
3288 for (; intr; intr = intr->next)
3290 if (intr->sym->attr.flavor == FL_DERIVED)
3292 if (sub_flag && intr->sym->attr.function)
3294 if (!sub_flag && intr->sym->attr.subroutine)
3297 if (gfc_arglist_matches_symbol (ap, intr->sym))
3299 if (has_null_arg && null_sym)
3301 gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "
3302 "between specific functions %s and %s",
3303 &null_expr_loc, null_sym->name, intr->sym->name);
3306 else if (has_null_arg)
3308 null_sym = intr->sym;
3312 /* Satisfy 12.4.4.1 such that an elemental match has lower
3313 weight than a non-elemental match. */
3314 if (intr->sym->attr.elemental)
3316 elem_sym = intr->sym;
3326 return elem_sym ? elem_sym : NULL;
3330 /* Do a brute force recursive search for a symbol. */
3332 static gfc_symtree *
3333 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
3337 if (root->n.sym == sym)
3342 st = find_symtree0 (root->left, sym);
3343 if (root->right && ! st)
3344 st = find_symtree0 (root->right, sym);
3349 /* Find a symtree for a symbol. */
3352 gfc_find_sym_in_symtree (gfc_symbol *sym)
3357 /* First try to find it by name. */
3358 gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
3359 if (st && st->n.sym == sym)
3362 /* If it's been renamed, resort to a brute-force search. */
3363 /* TODO: avoid having to do this search. If the symbol doesn't exist
3364 in the symtree for the current namespace, it should probably be added. */
3365 for (ns = gfc_current_ns; ns; ns = ns->parent)
3367 st = find_symtree0 (ns->sym_root, sym);
3371 gfc_internal_error ("Unable to find symbol %s", sym->name);
3376 /* See if the arglist to an operator-call contains a derived-type argument
3377 with a matching type-bound operator. If so, return the matching specific
3378 procedure defined as operator-target as well as the base-object to use
3379 (which is the found derived-type argument with operator). The generic
3380 name, if any, is transmitted to the final expression via 'gname'. */
3382 static gfc_typebound_proc*
3383 matching_typebound_op (gfc_expr** tb_base,
3384 gfc_actual_arglist* args,
3385 gfc_intrinsic_op op, const char* uop,
3386 const char ** gname)
3388 gfc_actual_arglist* base;
3390 for (base = args; base; base = base->next)
3391 if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
3393 gfc_typebound_proc* tb;
3394 gfc_symbol* derived;
3397 while (base->expr->expr_type == EXPR_OP
3398 && base->expr->value.op.op == INTRINSIC_PARENTHESES)
3399 base->expr = base->expr->value.op.op1;
3401 if (base->expr->ts.type == BT_CLASS)
3403 if (CLASS_DATA (base->expr) == NULL
3404 || !gfc_expr_attr (base->expr).class_ok)
3406 derived = CLASS_DATA (base->expr)->ts.u.derived;
3409 derived = base->expr->ts.u.derived;
3411 if (op == INTRINSIC_USER)
3413 gfc_symtree* tb_uop;
3416 tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
3425 tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
3428 /* This means we hit a PRIVATE operator which is use-associated and
3429 should thus not be seen. */
3430 if (result == FAILURE)
3433 /* Look through the super-type hierarchy for a matching specific
3435 for (; tb; tb = tb->overridden)
3439 gcc_assert (tb->is_generic);
3440 for (g = tb->u.generic; g; g = g->next)
3443 gfc_actual_arglist* argcopy;
3446 gcc_assert (g->specific);
3447 if (g->specific->error)
3450 target = g->specific->u.specific->n.sym;
3452 /* Check if this arglist matches the formal. */
3453 argcopy = gfc_copy_actual_arglist (args);
3454 matches = gfc_arglist_matches_symbol (&argcopy, target);
3455 gfc_free_actual_arglist (argcopy);
3457 /* Return if we found a match. */
3460 *tb_base = base->expr;
3461 *gname = g->specific_st->name;
3472 /* For the 'actual arglist' of an operator call and a specific typebound
3473 procedure that has been found the target of a type-bound operator, build the
3474 appropriate EXPR_COMPCALL and resolve it. We take this indirection over
3475 type-bound procedures rather than resolving type-bound operators 'directly'
3476 so that we can reuse the existing logic. */
3479 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
3480 gfc_expr* base, gfc_typebound_proc* target,
3483 e->expr_type = EXPR_COMPCALL;
3484 e->value.compcall.tbp = target;
3485 e->value.compcall.name = gname ? gname : "$op";
3486 e->value.compcall.actual = actual;
3487 e->value.compcall.base_object = base;
3488 e->value.compcall.ignore_pass = 1;
3489 e->value.compcall.assign = 0;
3490 if (e->ts.type == BT_UNKNOWN
3491 && target->function)
3493 if (target->is_generic)
3494 e->ts = target->u.generic->specific->u.specific->n.sym->ts;
3496 e->ts = target->u.specific->n.sym->ts;
3501 /* This subroutine is called when an expression is being resolved.
3502 The expression node in question is either a user defined operator
3503 or an intrinsic operator with arguments that aren't compatible
3504 with the operator. This subroutine builds an actual argument list
3505 corresponding to the operands, then searches for a compatible
3506 interface. If one is found, the expression node is replaced with
3507 the appropriate function call. We use the 'match' enum to specify
3508 whether a replacement has been made or not, or if an error occurred. */
3511 gfc_extend_expr (gfc_expr *e)
3513 gfc_actual_arglist *actual;
3522 actual = gfc_get_actual_arglist ();
3523 actual->expr = e->value.op.op1;
3527 if (e->value.op.op2 != NULL)
3529 actual->next = gfc_get_actual_arglist ();
3530 actual->next->expr = e->value.op.op2;
3533 i = fold_unary_intrinsic (e->value.op.op);
3535 if (i == INTRINSIC_USER)
3537 for (ns = gfc_current_ns; ns; ns = ns->parent)
3539 uop = gfc_find_uop (e->value.op.uop->name, ns);
3543 sym = gfc_search_interface (uop->op, 0, &actual);
3550 for (ns = gfc_current_ns; ns; ns = ns->parent)
3552 /* Due to the distinction between '==' and '.eq.' and friends, one has
3553 to check if either is defined. */
3556 #define CHECK_OS_COMPARISON(comp) \
3557 case INTRINSIC_##comp: \
3558 case INTRINSIC_##comp##_OS: \
3559 sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
3561 sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
3563 CHECK_OS_COMPARISON(EQ)
3564 CHECK_OS_COMPARISON(NE)
3565 CHECK_OS_COMPARISON(GT)
3566 CHECK_OS_COMPARISON(GE)
3567 CHECK_OS_COMPARISON(LT)
3568 CHECK_OS_COMPARISON(LE)
3569 #undef CHECK_OS_COMPARISON
3572 sym = gfc_search_interface (ns->op[i], 0, &actual);
3580 /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
3581 found rather than just taking the first one and not checking further. */
3585 gfc_typebound_proc* tbo;
3588 /* See if we find a matching type-bound operator. */
3589 if (i == INTRINSIC_USER)
3590 tbo = matching_typebound_op (&tb_base, actual,
3591 i, e->value.op.uop->name, &gname);
3595 #define CHECK_OS_COMPARISON(comp) \
3596 case INTRINSIC_##comp: \
3597 case INTRINSIC_##comp##_OS: \
3598 tbo = matching_typebound_op (&tb_base, actual, \
3599 INTRINSIC_##comp, NULL, &gname); \
3601 tbo = matching_typebound_op (&tb_base, actual, \
3602 INTRINSIC_##comp##_OS, NULL, &gname); \
3604 CHECK_OS_COMPARISON(EQ)
3605 CHECK_OS_COMPARISON(NE)
3606 CHECK_OS_COMPARISON(GT)
3607 CHECK_OS_COMPARISON(GE)
3608 CHECK_OS_COMPARISON(LT)
3609 CHECK_OS_COMPARISON(LE)
3610 #undef CHECK_OS_COMPARISON
3613 tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3617 /* If there is a matching typebound-operator, replace the expression with
3618 a call to it and succeed. */
3623 gcc_assert (tb_base);
3624 build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3626 result = gfc_resolve_expr (e);
3627 if (result == FAILURE)
3633 /* Don't use gfc_free_actual_arglist(). */
3634 free (actual->next);
3640 /* Change the expression node to a function call. */
3641 e->expr_type = EXPR_FUNCTION;
3642 e->symtree = gfc_find_sym_in_symtree (sym);
3643 e->value.function.actual = actual;
3644 e->value.function.esym = NULL;
3645 e->value.function.isym = NULL;
3646 e->value.function.name = NULL;
3647 e->user_operator = 1;
3649 if (gfc_resolve_expr (e) == FAILURE)
3656 /* Tries to replace an assignment code node with a subroutine call to
3657 the subroutine associated with the assignment operator. Return
3658 SUCCESS if the node was replaced. On FAILURE, no error is
3662 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3664 gfc_actual_arglist *actual;
3665 gfc_expr *lhs, *rhs;
3674 /* Don't allow an intrinsic assignment to be replaced. */
3675 if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3676 && (rhs->rank == 0 || rhs->rank == lhs->rank)
3677 && (lhs->ts.type == rhs->ts.type
3678 || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3681 actual = gfc_get_actual_arglist ();
3684 actual->next = gfc_get_actual_arglist ();
3685 actual->next->expr = rhs;
3689 for (; ns; ns = ns->parent)
3691 sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3696 /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
3700 gfc_typebound_proc* tbo;
3703 /* See if we find a matching type-bound assignment. */
3704 tbo = matching_typebound_op (&tb_base, actual,
3705 INTRINSIC_ASSIGN, NULL, &gname);
3707 /* If there is one, replace the expression with a call to it and
3711 gcc_assert (tb_base);
3712 c->expr1 = gfc_get_expr ();
3713 build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3714 c->expr1->value.compcall.assign = 1;
3715 c->expr1->where = c->loc;
3717 c->op = EXEC_COMPCALL;
3719 /* c is resolved from the caller, so no need to do it here. */
3724 free (actual->next);
3729 /* Replace the assignment with the call. */
3730 c->op = EXEC_ASSIGN_CALL;
3731 c->symtree = gfc_find_sym_in_symtree (sym);
3734 c->ext.actual = actual;
3740 /* Make sure that the interface just parsed is not already present in
3741 the given interface list. Ambiguity isn't checked yet since module
3742 procedures can be present without interfaces. */
3745 gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc)
3749 for (ip = base; ip; ip = ip->next)
3751 if (ip->sym == new_sym)
3753 gfc_error ("Entity '%s' at %L is already present in the interface",
3754 new_sym->name, &loc);
3763 /* Add a symbol to the current interface. */
3766 gfc_add_interface (gfc_symbol *new_sym)
3768 gfc_interface **head, *intr;
3772 switch (current_interface.type)
3774 case INTERFACE_NAMELESS:
3775 case INTERFACE_ABSTRACT:
3778 case INTERFACE_INTRINSIC_OP:
3779 for (ns = current_interface.ns; ns; ns = ns->parent)
3780 switch (current_interface.op)
3783 case INTRINSIC_EQ_OS:
3784 if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
3785 gfc_current_locus) == FAILURE
3786 || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym,
3787 gfc_current_locus) == FAILURE)
3792 case INTRINSIC_NE_OS:
3793 if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
3794 gfc_current_locus) == FAILURE
3795 || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym,
3796 gfc_current_locus) == FAILURE)
3801 case INTRINSIC_GT_OS:
3802 if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym,
3803 gfc_current_locus) == FAILURE
3804 || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym,
3805 gfc_current_locus) == FAILURE)
3810 case INTRINSIC_GE_OS:
3811 if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym,
3812 gfc_current_locus) == FAILURE
3813 || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym,
3814 gfc_current_locus) == FAILURE)
3819 case INTRINSIC_LT_OS:
3820 if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym,
3821 gfc_current_locus) == FAILURE
3822 || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym,
3823 gfc_current_locus) == FAILURE)
3828 case INTRINSIC_LE_OS:
3829 if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym,
3830 gfc_current_locus) == FAILURE
3831 || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym,
3832 gfc_current_locus) == FAILURE)
3837 if (gfc_check_new_interface (ns->op[current_interface.op], new_sym,
3838 gfc_current_locus) == FAILURE)
3842 head = ¤t_interface.ns->op[current_interface.op];
3845 case INTERFACE_GENERIC:
3846 for (ns = current_interface.ns; ns; ns = ns->parent)
3848 gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3852 if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus)
3857 head = ¤t_interface.sym->generic;
3860 case INTERFACE_USER_OP:
3861 if (gfc_check_new_interface (current_interface.uop->op, new_sym,
3862 gfc_current_locus) == FAILURE)
3865 head = ¤t_interface.uop->op;
3869 gfc_internal_error ("gfc_add_interface(): Bad interface type");
3872 intr = gfc_get_interface ();
3873 intr->sym = new_sym;
3874 intr->where = gfc_current_locus;
3884 gfc_current_interface_head (void)
3886 switch (current_interface.type)
3888 case INTERFACE_INTRINSIC_OP:
3889 return current_interface.ns->op[current_interface.op];
3892 case INTERFACE_GENERIC:
3893 return current_interface.sym->generic;
3896 case INTERFACE_USER_OP:
3897 return current_interface.uop->op;
3907 gfc_set_current_interface_head (gfc_interface *i)
3909 switch (current_interface.type)
3911 case INTERFACE_INTRINSIC_OP:
3912 current_interface.ns->op[current_interface.op] = i;
3915 case INTERFACE_GENERIC:
3916 current_interface.sym->generic = i;
3919 case INTERFACE_USER_OP:
3920 current_interface.uop->op = i;
3929 /* Gets rid of a formal argument list. We do not free symbols.
3930 Symbols are freed when a namespace is freed. */
3933 gfc_free_formal_arglist (gfc_formal_arglist *p)
3935 gfc_formal_arglist *q;
3945 /* Check that it is ok for the type-bound procedure 'proc' to override the
3946 procedure 'old', cf. F08:4.5.7.3. */
3949 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
3952 gfc_symbol *proc_target, *old_target;
3953 unsigned proc_pass_arg, old_pass_arg, argpos;
3954 gfc_formal_arglist *proc_formal, *old_formal;
3958 /* This procedure should only be called for non-GENERIC proc. */
3959 gcc_assert (!proc->n.tb->is_generic);
3961 /* If the overwritten procedure is GENERIC, this is an error. */
3962 if (old->n.tb->is_generic)
3964 gfc_error ("Can't overwrite GENERIC '%s' at %L",
3965 old->name, &proc->n.tb->where);
3969 where = proc->n.tb->where;
3970 proc_target = proc->n.tb->u.specific->n.sym;
3971 old_target = old->n.tb->u.specific->n.sym;
3973 /* Check that overridden binding is not NON_OVERRIDABLE. */
3974 if (old->n.tb->non_overridable)
3976 gfc_error ("'%s' at %L overrides a procedure binding declared"
3977 " NON_OVERRIDABLE", proc->name, &where);
3981 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
3982 if (!old->n.tb->deferred && proc->n.tb->deferred)
3984 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
3985 " non-DEFERRED binding", proc->name, &where);
3989 /* If the overridden binding is PURE, the overriding must be, too. */
3990 if (old_target->attr.pure && !proc_target->attr.pure)
3992 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
3993 proc->name, &where);
3997 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
3998 is not, the overriding must not be either. */
3999 if (old_target->attr.elemental && !proc_target->attr.elemental)
4001 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
4002 " ELEMENTAL", proc->name, &where);
4005 if (!old_target->attr.elemental && proc_target->attr.elemental)
4007 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
4008 " be ELEMENTAL, either", proc->name, &where);
4012 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
4014 if (old_target->attr.subroutine && !proc_target->attr.subroutine)
4016 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
4017 " SUBROUTINE", proc->name, &where);
4021 /* If the overridden binding is a FUNCTION, the overriding must also be a
4022 FUNCTION and have the same characteristics. */
4023 if (old_target->attr.function)
4025 if (!proc_target->attr.function)
4027 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
4028 " FUNCTION", proc->name, &where);
4032 if (check_result_characteristics (proc_target, old_target,
4033 err, sizeof(err)) == FAILURE)
4035 gfc_error ("Result mismatch for the overriding procedure "
4036 "'%s' at %L: %s", proc->name, &where, err);
4041 /* If the overridden binding is PUBLIC, the overriding one must not be
4043 if (old->n.tb->access == ACCESS_PUBLIC
4044 && proc->n.tb->access == ACCESS_PRIVATE)
4046 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
4047 " PRIVATE", proc->name, &where);
4051 /* Compare the formal argument lists of both procedures. This is also abused
4052 to find the position of the passed-object dummy arguments of both
4053 bindings as at least the overridden one might not yet be resolved and we
4054 need those positions in the check below. */
4055 proc_pass_arg = old_pass_arg = 0;
4056 if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
4058 if (!old->n.tb->nopass && !old->n.tb->pass_arg)
4061 for (proc_formal = proc_target->formal, old_formal = old_target->formal;
4062 proc_formal && old_formal;
4063 proc_formal = proc_formal->next, old_formal = old_formal->next)
4065 if (proc->n.tb->pass_arg
4066 && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
4067 proc_pass_arg = argpos;
4068 if (old->n.tb->pass_arg
4069 && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
4070 old_pass_arg = argpos;
4072 /* Check that the names correspond. */
4073 if (strcmp (proc_formal->sym->name, old_formal->sym->name))
4075 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
4076 " to match the corresponding argument of the overridden"
4077 " procedure", proc_formal->sym->name, proc->name, &where,
4078 old_formal->sym->name);
4082 check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
4083 if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
4084 check_type, err, sizeof(err)) == FAILURE)
4086 gfc_error ("Argument mismatch for the overriding procedure "
4087 "'%s' at %L: %s", proc->name, &where, err);
4093 if (proc_formal || old_formal)
4095 gfc_error ("'%s' at %L must have the same number of formal arguments as"
4096 " the overridden procedure", proc->name, &where);
4100 /* If the overridden binding is NOPASS, the overriding one must also be
4102 if (old->n.tb->nopass && !proc->n.tb->nopass)
4104 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
4105 " NOPASS", proc->name, &where);
4109 /* If the overridden binding is PASS(x), the overriding one must also be
4110 PASS and the passed-object dummy arguments must correspond. */
4111 if (!old->n.tb->nopass)
4113 if (proc->n.tb->nopass)
4115 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
4116 " PASS", proc->name, &where);
4120 if (proc_pass_arg != old_pass_arg)
4122 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
4123 " the same position as the passed-object dummy argument of"
4124 " the overridden procedure", proc->name, &where);